From 837631fa0d9a096268cae7be2c34629b3b74ffd9 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Wed, 2 Apr 2025 05:11:40 +1100 Subject: [PATCH] update src/project_layouts --- .../custom/_project/punk.basic/src/make.tcl | 418 +- .../bootsupport/modules/commandstack-0.3.tm | 1028 +- .../src/bootsupport/modules/fauxlink-0.1.1.tm | 21 +- .../src/bootsupport/modules/metaface-1.2.5.tm | 12822 ++++++++-------- .../src/bootsupport/modules/modpod-0.1.0.tm | 705 - .../bootsupport/modules/natsort-0.1.1.5.tm | 1894 --- .../bootsupport/modules/patterncmd-1.2.4.tm | 1288 +- .../modules/patternpredator2-1.2.4.tm | 1508 +- .../bootsupport/modules/punk/ansi-0.1.1.tm | 3 +- .../punk/cap/handlers/templates-0.1.0.tm | 65 +- .../bootsupport/modules/punk/config-0.1.tm | 972 +- .../bootsupport/modules/punk/mix/base-0.1.tm | 5 +- .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 20 +- .../punk/mix/commandset/buildsuite-0.1.0.tm | 2 +- .../punk/mix/commandset/debug-0.1.0.tm | 8 +- .../punk/mix/commandset/module-0.1.0.tm | 6 +- .../punk/mix/commandset/project-0.1.0.tm | 170 +- .../modules/punk/mix/commandset/repo-0.1.0.tm | 38 +- .../mix/templates/utility/a b/tcltest.bat | 7 - .../src/bootsupport/modules/punk/mod-0.1.tm | 327 +- .../bootsupport/modules/punk/path-0.1.0.tm | 21 +- .../bootsupport/modules/punk/repo-0.1.1.tm | 240 +- .../src/bootsupport/modules/punkapp-0.1.tm | 478 +- .../bootsupport/modules/punkcheck-0.1.0.tm | 114 +- .../bootsupport/modules/test/tomlish-1.1.1.tm | Bin 46279 -> 35259 bytes .../bootsupport/modules/test/tomlish-1.1.3.tm | Bin 0 -> 41457 bytes .../bootsupport/modules/textblock-0.1.1.tm | 7408 --------- .../src/bootsupport/modules/tomlish-1.1.2.tm | 160 +- .../src/bootsupport/modules/tomlish-1.1.3.tm | 6002 ++++++++ .../_project/punk.project-0.1/src/make.tcl | 418 +- .../bootsupport/modules/commandstack-0.3.tm | 1028 +- .../src/bootsupport/modules/fauxlink-0.1.1.tm | 21 +- .../src/bootsupport/modules/metaface-1.2.5.tm | 12822 ++++++++-------- .../bootsupport/modules/patterncmd-1.2.4.tm | 1288 +- .../modules/patternpredator2-1.2.4.tm | 1508 +- .../bootsupport/modules/punk/ansi-0.1.1.tm | 3 +- .../punk/cap/handlers/templates-0.1.0.tm | 65 +- .../bootsupport/modules/punk/config-0.1.tm | 972 +- .../bootsupport/modules/punk/mix/base-0.1.tm | 5 +- .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 20 +- .../punk/mix/commandset/buildsuite-0.1.0.tm | 2 +- .../punk/mix/commandset/debug-0.1.0.tm | 8 +- .../punk/mix/commandset/module-0.1.0.tm | 6 +- .../punk/mix/commandset/project-0.1.0.tm | 170 +- .../modules/punk/mix/commandset/repo-0.1.0.tm | 38 +- .../src/bootsupport/modules/punk/mod-0.1.tm | 327 +- .../bootsupport/modules/punk/path-0.1.0.tm | 21 +- .../bootsupport/modules/punk/repo-0.1.1.tm | 240 +- .../src/bootsupport/modules/punkapp-0.1.tm | 478 +- .../bootsupport/modules/punkcheck-0.1.0.tm | 114 +- .../bootsupport/modules/test/tomlish-1.1.1.tm | Bin 46279 -> 35259 bytes .../bootsupport/modules/test/tomlish-1.1.3.tm | Bin 0 -> 41457 bytes .../src/bootsupport/modules/tomlish-1.1.2.tm | 160 +- .../src/bootsupport/modules/tomlish-1.1.3.tm | 6002 ++++++++ .../_project/punk.shell-0.1/src/make.tcl | 418 +- .../src/bootsupport/modules/argp-0.2.tm | 259 + .../modules/argparsingtest-0.1.0.tm | 568 + .../bootsupport/modules/commandstack-0.3.tm | 514 + .../src/bootsupport/modules/debug-1.0.6.tm | 306 + .../bootsupport/modules/fauxlink-0.1.1.tm} | 29 +- .../bootsupport/modules/fileutil/paths-1.tm | 74 + .../modules/fileutil/traverse-0.6.tm | 504 + .../src/bootsupport/modules/flagfilter-0.3.tm | 2714 ++++ .../src/bootsupport/modules/funcl-0.1.tm | 325 + .../src/bootsupport/modules/logger-0.9.5.tm | 1297 ++ .../src/bootsupport/modules/metaface-1.2.5.tm | 6411 ++++++++ .../src/bootsupport/modules/modpod-0.1.0.tm | 705 - .../src/bootsupport/modules/modpod-0.1.2.tm} | 37 +- .../bootsupport/modules/natsort-0.1.1.6.tm | 33 +- .../src/bootsupport/modules/overtype-1.6.5.tm | 2711 +++- .../src/bootsupport/modules/pattern-1.2.4.tm | 1285 ++ .../bootsupport/modules/patterncmd-1.2.4.tm | 645 + .../bootsupport/modules/patternlib-1.2.6.tm | 2590 ++++ .../modules/patternpredator2-1.2.4.tm | 754 + .../src/bootsupport/modules/promise-1.2.0.tm | 1311 ++ .../src/bootsupport/modules/punk-0.1.tm | 8187 ++++++++++ .../modules/punk/aliascore-0.1.0.tm | 290 + .../bootsupport/modules/punk/ansi-0.1.1.tm | 2498 ++- .../bootsupport/modules/punk/args-0.1.0.tm | 5395 ++++++- .../modules/punk/assertion-0.1.0.tm | 48 +- .../src/bootsupport/modules/punk/cap-0.1.0.tm | 60 +- .../punk/cap/handlers/caphandler-0.1.0.tm | 4 +- .../punk/cap/handlers/templates-0.1.0.tm | 158 +- .../bootsupport/modules/punk/char-0.1.0.tm | 591 +- .../bootsupport/modules/punk/config-0.1.tm | 487 + .../bootsupport/modules/punk/console-0.1.1.tm | 1586 +- .../bootsupport/modules/punk/docgen-0.1.0.tm | 1 + .../src/bootsupport/modules/punk/du-0.1.0.tm | 403 +- .../modules/punk/fileline-0.1.0.tm | 219 +- .../src/bootsupport/modules/punk/lib-0.1.1.tm | 2401 ++- .../bootsupport/modules/punk/mix/base-0.1.tm | 172 +- .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 376 +- .../bootsupport/modules/punk/mix/cli-0.3.tm | 1128 ++ .../punk/mix/commandset/buildsuite-0.1.0.tm | 2 +- .../punk/mix/commandset/debug-0.1.0.tm | 8 +- .../modules/punk/mix/commandset/doc-0.1.0.tm | 42 +- .../punk/mix/commandset/layout-0.1.0.tm | 118 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 43 +- .../punk/mix/commandset/module-0.1.0.tm | 126 +- .../punk/mix/commandset/project-0.1.0.tm | 253 +- .../modules/punk/mix/commandset/repo-0.1.0.tm | 39 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 100 +- .../modules/punk/mix/templates-0.1.0.tm | 6 +- .../modpod/template_modpod-0.0.1/test.zip | Bin 0 -> 1275 bytes .../modules/modulename_buildversion.txt | 2 +- .../modules/punk/mix/util-0.1.0.tm | 16 +- .../src/bootsupport/modules/punk/mod-0.1.tm | 164 + .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 1491 ++ .../src/bootsupport/modules/punk/ns-0.1.0.tm | 1492 +- .../bootsupport/modules/punk/overlay-0.1.tm | 4 + .../modules/punk/packagepreference-0.1.0.tm | 420 + .../bootsupport/modules/punk/path-0.1.0.tm | 584 +- .../src/bootsupport/modules/punk/pipe-1.0.tm | 853 + .../modules/punk/repl/codethread-0.1.0.tm | 276 + .../modules/punk/repl/codethread-0.1.1.tm | 321 + .../bootsupport/modules/punk/repo-0.1.1.tm | 472 +- .../src/bootsupport/modules/punk/tdl-0.1.0.tm | 11 +- .../bootsupport/modules/punk/trie-0.1.0.tm | 605 + .../modules/punk/unixywindows-0.1.0.tm | 237 + .../bootsupport/modules/punk/winpath-0.1.0.tm | 155 +- .../src/bootsupport/modules/punk/zip-0.1.0.tm | 761 + .../src/bootsupport/modules/punk/zip-0.1.1.tm | 861 ++ .../src/bootsupport/modules/punkapp-0.1.tm | 239 + .../bootsupport/modules/punkcheck-0.1.0.tm | 355 +- .../modules/punkcheck/cli-0.1.0.tm | 335 + .../bootsupport/modules/shellfilter-0.1.9.tm | 3122 ++++ .../bootsupport/modules/test/tomlish-1.1.1.tm | Bin 0 -> 41364 bytes .../bootsupport/modules/textblock-0.1.1.tm | 7226 --------- .../bootsupport/modules/textblock-0.1.3.tm} | 1387 +- .../src/bootsupport/modules/textutil-0.9.tm | 2 +- .../modules/textutil/wcswidth-35.2.tm | 2 +- .../src/bootsupport/modules/tomlish-1.1.2.tm} | 662 +- .../src/bootsupport/modules/tomlish-1.1.3.tm | 6002 ++++++++ .../src/bootsupport/modules/uuid-1.0.8.tm | 246 + .../src/bootsupport/modules/zipper-0.12.tm} | Bin 9248 -> 9842 bytes .../vendor/punk/project-0.1/src/make.tcl | 2018 ++- 136 files changed, 96844 insertions(+), 43154 deletions(-) delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/natsort-0.1.1.5.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates/utility/a b/tcltest.bat create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.3.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.3.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.3.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.3.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/argp-0.2.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/commandstack-0.3.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/debug-1.0.6.tm rename src/project_layouts/{custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm => vendor/punk/project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm} (95%) create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil/paths-1.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil/traverse-0.6.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/flagfilter-0.3.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/funcl-0.1.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/logger-0.9.5.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/metaface-1.2.5.tm delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.0.tm rename src/project_layouts/{custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.1.tm => vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.2.tm} (95%) create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/pattern-1.2.4.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/patternlib-1.2.6.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/promise-1.2.0.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk-0.1.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/config-0.1.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mod-0.1.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/pipe-1.0.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/unixywindows-0.1.0.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/zip-0.1.0.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punkapp-0.1.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textblock-0.1.1.tm rename src/project_layouts/{custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm => vendor/punk/project-0.1/src/bootsupport/modules/textblock-0.1.3.tm} (93%) rename src/project_layouts/{custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.1.tm => vendor/punk/project-0.1/src/bootsupport/modules/tomlish-1.1.2.tm} (87%) create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/tomlish-1.1.3.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/uuid-1.0.8.tm rename src/project_layouts/{custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.11.tm => vendor/punk/project-0.1/src/bootsupport/modules/zipper-0.12.tm} (67%) 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 6776eb79..775335c3 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -2,12 +2,15 @@ # # punkboot - make any tclkits and modules in /src folders and place them and associated data files/scripts in the parent folder of src. #e.g in 'bin' and 'modules' folders at same level as 'src' folder. +if {[info exists ::env(NO_COLOR)]} { + namespace eval ::punk::console {variable colour_disabled 1} +} set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" puts $hashline -puts " Punk Boot" +puts " Punk Boot" puts $hashline\n -package prefer latest +package prefer latest lassign [split [info tclversion] .] tclmajorv tclminorv global A ;#UI Ansi code array @@ -104,7 +107,7 @@ namespace eval ::punkboot::lib { } } return [join $newparts .] - } + } proc tm_version_required_canonical {versionspec} { #also trim leading zero from any dottedpart? #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. @@ -112,10 +115,10 @@ namespace eval ::punkboot::lib { #also 1b3 == 1b0003 if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version - set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification" + set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification" if {[string first - $versionspec] < 0} { - #no dash - #looks like a minbounded version (ie a single version with no dash) convert to min-max form + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form set from $versionspec if {![::punkboot::lib::tm_version_isvalid $from]} { error "$errmsg '$versionpec'" @@ -127,7 +130,7 @@ namespace eval ::punkboot::lib { error "$errmsg '$versionspec'" } } else { - # min- or min-max + # min- or min-max #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) set parts [split $versionspec -] ;#we expect only 2 parts lassign $parts from to @@ -162,18 +165,18 @@ if {"::try" ni [info commands ::try]} { #------------------------------------------------------------------------------ #Module loading from src/bootsupport or [pwd]/modules if pwd is a 'src' folder #------------------------------------------------------------------------------ -#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files +#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files # - then it will attempt to preference these modules # This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the boot script # and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables set startdir [pwd] #we are focussed on pure-tcl libs/modules in bootsupport for now. -#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc +#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc #REVIEW - punkboot can really speed up with appropriate accelerators and/or external binaries # - we need to support that without binary downloads from repos unless the user explicitly asks for that. # - They may already be available in the vfs (or pointed to package paths) of the running executable. # - todo: some user prompting regarding installs with platform-appropriate package managers -# - todo: some user prompting regarding building accelerators from source. +# - todo: some user prompting regarding building accelerators from source. # ------------------------------------------------------------------------------------- set bootsupport_module_paths [list] @@ -209,7 +212,7 @@ if {[file tail $startdir] eq "src"} { #todo - other src 'module' dirs.. foreach p [list $startdir/modules $startdir/modules_tcl$::tclmajorv $startdir/vendormodules $startdir/vendormodules_tcl$::tclmajorv] { if {[file exists $p]} { - lappend sourcesupport_module_paths $p + lappend sourcesupport_module_paths $p } } # -- -- -- @@ -219,7 +222,7 @@ if {[file tail $startdir] eq "src"} { } } # -- -- -- - + foreach p [list {*}$sourcesupport_module_paths {*}$sourcesupport_library_paths] { if {[file exists $p]} { set sourcesupport_paths_exist 1 @@ -228,7 +231,7 @@ if {[file tail $startdir] eq "src"} { } if {$sourcesupport_paths_exist} { - #launch from auto_path $::auto_path" @@ -281,18 +284,19 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { #package require Thread # - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly. - - + # tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list - #These are strong dependencies + #These are strong dependencies package forget punk::mix - package forget punk::repo - package forget punkcheck + package forget punk::repo + package forget punkcheck package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies package require punk::mix package require punkcheck package require punk::lib + package require punk::args + package require punk::ansi set package_paths_modified 1 @@ -302,11 +306,12 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { set ::punkboot::pkg_requirements_found [list] #we will treat 'package require .' (minbounded) as .- ie explicitly convert to corresponding bounded form -#put some with leading zeros to test normalisation +#put some with leading zeros to test normalisation set ::punkboot::bootsupport_requirements [dict create\ punk::repo [list version "00.01.01-"]\ punk::mix [list version ""]\ punk::ansi [list]\ + punk::args [list]\ overtype [list version "1.6.5-"]\ punkcheck [list]\ fauxlink [list version "0.1.1-"]\ @@ -322,7 +327,7 @@ dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { if {![catch {::punkboot::lib::tm_version_required_canonical $ver} canonical]} { if {$canonical ne $ver} { dict set pkginfo version $canonical ;# plain ver mapped to min-max. min- and min-max and empty left as is - dict set ::punkboot::bootsupport_requirements $pkg $pkginfo + dict set ::punkboot::bootsupport_requirements $pkg $pkginfo } } else { puts stderr "punkboot::bootsupport_requirements - package $pkg has invalid version specification '$ver'" @@ -331,9 +336,9 @@ dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { } else { #make sure each has a blank version entry if nothing was there. dict set pkginfo version "" - dict set ::punkboot::bootsupport_requirements $pkg $pkginfo + dict set ::punkboot::bootsupport_requirements $pkg $pkginfo } -} +} #Assert - our bootsupport_requirement version numbers should now be either empty or of the form min- or min-max #dict for {k v} $::punkboot::bootsupport_requirements { # puts "- $k $v" @@ -356,7 +361,7 @@ set ::punkboot::bootsupport_recommended [dict create\ # create an interp in which we hijack package command # This allows us to auto-gather some dependencies (not necessarily all and not necessarily strictly required) # Note: even in a separate interp we could still possibly get side-effects if a package has compiled components - REVIEW -# Hopefully the only side-effect is that a subsequent load of the package will be faster... +# Hopefully the only side-effect is that a subsequent load of the package will be faster... # (punk boot is intended to operate without compiled components - but some could be pulled in by tcl modules if they're found) # (tcllibc is also highly desirable as the performance impact when not available can be dramatic.) # ... but if the binary is loaded with a different path name when we come to actually use it - there could be issues. @@ -378,7 +383,7 @@ proc ::punkboot::check_package_availability {args} { #best effort at auto-determinining packages required (dependencies) based on top-level packages in the list. #Without fully parsing the package-loading Tcl scripts and examining all side-effects (an unlikely capability), # this is not going to be as accurate as the package developer providing a definitive list of which packages are required and which are optional. - # 'optionality' is a contextual concept anyway depending on how the package is intended to be used. + # 'optionality' is a contextual concept anyway depending on how the package is intended to be used. # The package developer may consider a feature optional - but it may not be optional in a particular usecase. set bootsupport_requirements [lindex $args end] @@ -484,7 +489,7 @@ proc ::punkboot::check_package_availability {args} { #should still distinguish: {pkgname {}} -valid vs {pkgname {{}}} due to empty string supplied in call - invalid - but leave for underlying package command to error on set pkgrequest [list $pkgname $requirements_list] if {$pkgrequest ni $::test::pkg_requested} { - lappend ::test::pkg_requested $pkgrequest + lappend ::test::pkg_requested $pkgrequest } # -- -- --- --- --- --- --- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -507,13 +512,13 @@ proc ::punkboot::check_package_availability {args} { } if {[llength $::test::pkg_stack]} { set caller [lindex $::test::pkg_stack end] - set required_by [dict get $pinfo required_by] + set required_by [dict get $pinfo required_by] if {$caller ni $required_by} { lappend required_by $caller } dict set pinfo required_by $required_by } - lappend ::test::pkg_stack $pkgname + lappend ::test::pkg_stack $pkgname #At this point we could short circuit if we've already classified this package/requirements combo as missing/broken from a previous require #review - there is some chance the exact pkg/requirements combo may succeed after an earlier failure if some package adjusted search paths.. @@ -527,23 +532,23 @@ proc ::punkboot::check_package_availability {args} { #use our normalised requirements instead of original args #if {[catch [list ::package_orig {*}$args] result]} {} if {[catch [list ::package_orig require $pkgname {*}$requirements_list] result]} { - dict set pinfo testerror $result + dict set pinfo testerror $result #package missing - or exists - but failing to initialise if {!$::opt_quiet} { set parent_path [lrange $::test::pkg_stack 0 end-1] puts stderr "\x1b\[32m $pkgname versions: $versions error: $result\x1b\[m" set parent_path [join $parent_path " -> "] - puts stderr "pkg requirements: $parent_path" + puts stderr "pkg requirements: $parent_path" puts stderr "error during : '$args'" puts stderr " \x1b\[93m$result\x1b\[m" } #the failed package may still exist - so we could check 'package files' and 'package ifneeded' here too - REVIEW - #to determine the version that we attempted to load, + #to determine the version that we attempted to load, #- we need to look at 'pkg versions' vs -exact / ver / ver-ver (using package vsatisfies) if {![llength $versions]} { #no versions *and* we had an error - missing is our best guess. review. - #'package versions Tcl' never shows any results + #'package versions Tcl' never shows any results #so requests for old versions will show as missing not broken. #This is probably better anyway. if {$pkgrequest ni $::test::pkg_missing} { @@ -572,21 +577,21 @@ proc ::punkboot::check_package_availability {args} { lappend selectable_versions $v } } else { - #we are operating under 'package prefer' = latest + #we are operating under 'package prefer' = latest set selectable_versions $ordered_versions } if {[llength $requirements_list]} { #add one or no entry for each requirement. #pick highest at end - set satisfiers [list] + set satisfiers [list] foreach requirement $requirements_list { foreach ver [lreverse $selectable_versions] { if {[package vsatisfies $ver $requirement]} { lappend satisfiers $ver break - } - } + } + } } if {[llength $satisfiers]} { set satisfiers [lsort -command {::package_orig vcompare} $satisfiers] @@ -622,7 +627,7 @@ proc ::punkboot::check_package_availability {args} { if {![catch {::package_orig files Tcl} ]} { #tcl9 (also some 8.6/8.7) has 'package files' subcommand. #unfortunately, in some cases (e.g md5 when no accelerators available) this can be a huge list (1000+) showing all scanned pkgIndex.tcl files from unrelated packages. - #We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour + #We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour #see: https://core.tcl-lang.org/tcl/tktview/209fd9adce set all_files [::package_orig files $pkgname] #some arbitrary threshold? REVIEW @@ -637,7 +642,7 @@ proc ::punkboot::check_package_availability {args} { dict set pinfo packagefiles {} ;#default #there are all sorts of scripts, so this is not predictably structured #e.g using things like apply - #we will attempt to get a trailing source .. + #we will attempt to get a trailing source .. set parts [split [string trim $ifneeded_script] {;}] set trimparts [list] foreach p $parts { @@ -648,7 +653,7 @@ proc ::punkboot::check_package_availability {args} { if {$last_with_text ne "" && [regexp -- {\S+$} $last_with_text lastword]} { #if it's a file or dir - close enough (?) #e.g tcllibc uses apply and the last entry is actuall a folder used to find the file.. - #we aren't brave enough to try to work out the actual file(s) + #we aren't brave enough to try to work out the actual file(s) if {[file exists $lastword]} { dict set pinfo packagefiles $lastword } @@ -662,10 +667,10 @@ proc ::punkboot::check_package_availability {args} { return [uplevel 1 [list ::package_orig {*}$args]] } } - + set ::test::pkg_stack [list] catch {::package_orig require zzz-non-existant} ;#scan so we get 'package versions' results - dict for {pkg pkgdict} $::test::bootsupport_requirements { + dict for {pkg pkgdict} $::test::bootsupport_requirements { #set nsquals [namespace qualifiers $pkg] #if {$nsquals ne ""} { # catch {::package_orig require ${nsquals}::zzz-non-existant} ;#force scan of every level encountered @@ -690,7 +695,7 @@ proc ::punkboot::check_package_availability {args} { # set ver [package provide $pkg] # if {$ver eq ""} { # #puts stderr "missing pkg: $pkg" - # lappend ::test::pkg_missing $pkg + # lappend ::test::pkg_missing $pkg # } else { # if {[string tolower $pkg] eq "tcl"} { # #ignore @@ -1180,17 +1185,17 @@ if {$::punkboot::command eq "check"} { puts stdout "- tcl::tm::list" foreach fld [tcl::tm::list] { if {[file exists $fld]} { - puts stdout " $fld" + puts stdout " $fld" } else { - puts stdout " $fld (not present)" + puts stdout " $fld (not present)" } } puts stdout "- auto_path" foreach fld $::auto_path { if {[file exists $fld]} { - puts stdout " $fld" + puts stdout " $fld" } else { - puts stdout " $fld (not present)" + puts stdout " $fld (not present)" } } flush stdout @@ -1283,22 +1288,22 @@ if {$::punkboot::command eq "info"} { set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] puts stdout "- vendorlib folders: ([llength $vendorlibfolders])" foreach fld $vendorlibfolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } puts stdout "- vendormodule folders: ([llength $vendormodulefolders])" foreach fld $vendormodulefolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] puts stdout "- source module paths: [llength $source_module_folderlist]" foreach fld $source_module_folderlist { - puts stdout " $fld" + puts stdout " $fld" } set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] lappend projectlibfolders lib puts stdout "- source libary paths: [llength $projectlibfolders]" foreach fld $projectlibfolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { set vc "fossil" @@ -1389,10 +1394,9 @@ if {$::punkboot::command eq "vendorupdate"} { #todo vendor/lib set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] - set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] - lappend vendormodulefolders vendormodules + set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] + #lappend vendormodulefolders vendormodules foreach vf $vendormodulefolders { - if {[file exists $sourcefolder/$vf]} { lassign [split $vf _] _vm tclx if {$tclx ne ""} { set which _$tclx @@ -1481,7 +1485,6 @@ if {$::punkboot::command eq "vendorupdate"} { } else { puts stderr "No config at $vendor_config - nothing configured to update" } - } } } @@ -1508,105 +1511,102 @@ if {$::punkboot::command eq "bootsupport"} { set bootsupport_modules [list] ;#variable populated by include_modules.config file - review set sourcefolder $projectroot/src - set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules_tcl*] - lappend bootmodulefolders modules + set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules modules_tcl*] foreach bm $bootmodulefolders { - if {[file exists $sourcefolder/bootsupport/$bm]} { - lassign [split $bm _] _bm tclx - if {$tclx ne ""} { - set which _$tclx + lassign [split $bm _] _bm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# + if {[file exists $bootsupport_config]} { + set targetroot $projectroot/src/bootsupport/modules$which + source $bootsupport_config ;#populate $bootsupport_modules with project-specific list + if {![llength $bootsupport_modules]} { + puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" } else { - set which "" - } - set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# - if {[file exists $bootsupport_config]} { - set targetroot $projectroot/src/bootsupport/modules$which - source $bootsupport_config ;#populate $bootsupport_modules with project-specific list - if {![llength $bootsupport_modules]} { - puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" - } else { - if {[catch { - #---------- - set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] - $boot_installer set_source_target $projectroot $projectroot/src/bootsupport - set boot_event [$boot_installer start_event {-make_step bootsupport}] - #---------- - } errM]} { - puts stderr "Unable to use punkcheck for bootsupport error: $errM" - set boot_event "" - } + if {[catch { + #---------- + set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] + $boot_installer set_source_target $projectroot $projectroot/src/bootsupport + set boot_event [$boot_installer start_event {-make_step bootsupport}] + #---------- + } errM]} { + puts stderr "Unable to use punkcheck for bootsupport error: $errM" + set boot_event "" + } - foreach {relpath modulematch} $bootsupport_modules { - set modulematch [string trim $modulematch :] - set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]] - set srclocation [file join $projectroot $relpath $module_subpath] - #puts stdout "$relpath $modulematch $module_subpath $srclocation" - if {[string first - $modulematch]} { - set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm] - } else { - set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm] - } - if {![llength $pkgmatches]} { - puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation" - continue - } + foreach {relpath modulematch} $bootsupport_modules { + set modulematch [string trim $modulematch :] + set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $modulematch $module_subpath $srclocation" + if {[string first - $modulematch]} { + set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm] + } else { + set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm] + } + if {![llength $pkgmatches]} { + puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation" + continue + } - set modulematch_is_glob [regexp {[*?\[\]]} $modulematch] - if {!$modulematch_is_glob} { - #if modulematch was specified without globs - only copy latest - #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func - set pkgmatches [lsort -command modfile_sort $pkgmatches] - set latestfile [lindex $pkgmatches end] - #set latestver [lindex [split [file rootname $latestfile] -] 1] - set copy_files $latestfile - } else { - #globs in modulematch - may be different packages matched by glob - copy all versions of matches - #review - set copy_files $pkgmatches - } - foreach cfile $copy_files { - set srcfile [file join $srclocation $cfile] - set tgtfile [file join $targetroot $module_subpath $cfile] - if {$boot_event ne ""} { - #---------- - $boot_event targetset_init INSTALL $tgtfile - $boot_event targetset_addsource $srcfile - #---------- - if {\ - [llength [dict get [$boot_event targetset_source_changes] changed]]\ - || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ - } { - file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists - $boot_event targetset_started - # -- --- --- --- --- --- - puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile" - if {[catch { - file copy -force $srcfile $tgtfile - } errM]} { - $boot_event targetset_end FAILED - } else { - $boot_event targetset_end OK - } - # -- --- --- --- --- --- + set modulematch_is_glob [regexp {[*?\[\]]} $modulematch] + if {!$modulematch_is_glob} { + #if modulematch was specified without globs - only copy latest + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func + set pkgmatches [lsort -command modfile_sort $pkgmatches] + set latestfile [lindex $pkgmatches end] + #set latestver [lindex [split [file rootname $latestfile] -] 1] + set copy_files $latestfile + } else { + #globs in modulematch - may be different packages matched by glob - copy all versions of matches + #review + set copy_files $pkgmatches + } + foreach cfile $copy_files { + set srcfile [file join $srclocation $cfile] + set tgtfile [file join $targetroot $module_subpath $cfile] + if {$boot_event ne ""} { + #---------- + $boot_event targetset_init INSTALL $tgtfile + $boot_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$boot_event targetset_source_changes] changed]]\ + || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ + } { + file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists + $boot_event targetset_started + # -- --- --- --- --- --- + puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $boot_event targetset_end FAILED } else { - puts -nonewline stderr "." - $boot_event targetset_end SKIPPED + $boot_event targetset_end OK } - $boot_event end + # -- --- --- --- --- --- } else { - file copy -force $srcfile $tgtfile + puts -nonewline stderr "." + $boot_event targetset_end SKIPPED } + $boot_event end + } else { + file copy -force $srcfile $tgtfile } } - if {$boot_event ne ""} { - puts \n - $boot_event destroy - $boot_installer destroy - } } - + if {$boot_event ne ""} { + puts \n + $boot_event destroy + $boot_installer destroy + } } + } } } @@ -1699,59 +1699,53 @@ if {$::punkboot::command ni {project modules vfs}} { #install src vendor contents (from version controlled src folder) to base of project (same target folders as our own src/modules etc ie to paths that go on the auto_path and in tcl::tm::list) if {$::punkboot::command in {project modules}} { - set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] - lappend vendorlibfolders vendorlib - foreach lf $vendorlibfolders { - if {[file exists $sourcefolder/$lf]} { - lassign [split $lf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_lib_folder $projectroot/lib$which - file mkdir $projectroot/lib$which - #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g - # */test.txt will only match test.txt exactly one level deep. - # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. - # **/test.txt will match at any level below the root (but not in the root) - set antipaths [list\ - README.md\ - ] - puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] - } - } - if {![llength $vendorlibfolders]} { - puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." - } - - set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] - lappend vendormodulefolders vendormodules - + set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] foreach vf $vendormodulefolders { - if {[file exists $sourcefolder/$vf]} { - lassign [split $vf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_module_folder $projectroot/modules$which - file mkdir $target_module_folder - - #install .tm *and other files* - puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] + lassign [split $vf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" } + set target_module_folder $projectroot/modules$which + file mkdir $target_module_folder + + #install .tm *and other files* + puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $vendormodulefolders]} { puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found." } + set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib vendorlib_tcl*] + foreach lf $vendorlibfolders { + lassign [split $lf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_lib_folder $projectroot/lib$which + file mkdir $projectroot/lib$which + #exclude README.md from source folder - but only the root one + #-antiglob_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) + set antipaths [list\ + README.md\ + ] + puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } + if {![llength $vendorlibfolders]} { + puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." + } + + ######################################################## #templates #e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync @@ -1760,10 +1754,10 @@ if {$::punkboot::command in {project modules}} { set old_layout_update_list [list\ [list project $sourcefolder/modules/punk/mix/templates]\ [list basic $sourcefolder/mixtemplates]\ - ] + ] set layout_bases [list\ $sourcefolder/project_layouts/custom/_project\ - ] + ] foreach layoutbase $layout_bases { if {![file exists $layoutbase]} { @@ -1823,27 +1817,25 @@ if {$::punkboot::command in {project modules}} { set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] lappend projectlibfolders lib foreach lf $projectlibfolders { - if {[file exists $sourcefolder/$lf]} { - lassign [split $lf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_lib_folder $projectroot/lib$which - file mkdir $projectroot/lib$which - #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g - # */test.txt will only match test.txt exactly one level deep. - # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. - # **/test.txt will match at any level below the root (but not in the root) - set antipaths [list\ - README.md\ - ] - puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] - } + lassign [split $lf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_lib_folder $projectroot/lib$which + file mkdir $projectroot/lib$which + #exclude README.md from source folder - but only the root one + #-antiglob_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) + set antipaths [list\ + README.md\ + ] + puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $projectlibfolders]} { puts stderr "PROJECTLIB: No src/lib or src/lib_tcl* folder found." @@ -2355,7 +2347,7 @@ foreach vfstail $vfs_tails { } else { lappend runtimes $matchrt } - } + } } #assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm index a45eaeaf..7884214c 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm @@ -1,514 +1,514 @@ - - -#JMN 2021 - Public Domain -#cooperative command renaming -# -# REVIEW 2024 - code was originally for specific use in packageTrace -# - code should be reviewed for more generic utility. -# - API is obscure and undocumented. -# - unclear if intention was only for builtins -# - consider use of newer 'info cmdtype' - (but need also support for safe interps) -# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. -# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename -#changes: -#2024 -# - mungecommand to support namespaced commands -# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ -#2021-09-18 -# - initial version -# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command -# - They need to be able to load and unload in any order. -# - -#strive for no other package dependencies here. - - -namespace eval commandstack { - variable all_stacks - variable debug - set debug 0 - variable known_renamers [list ::packagetrace ::packageSuppress] - if {![info exists all_stacks]} { - #don't wipe it - set all_stacks [dict create] - } -} - -namespace eval commandstack::util { - #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. - #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace - #A magic comment was chosen as the identifying method. - #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. - - #return unspecified if the command is a proc with a body but no magic comment ID - #return unknown if the command doesn't have a proc body to analyze - #otherwise return the package name identified in the magic comment - proc get_IMPLEMENTOR {command} { - #assert - command has already been resolved to a namespace ie fully qualified - if {[llength [info procs $command]]} { - #look for *IMPLEMENTOR_*! - set prefix IMPLEMENTOR_ - set suffix "!" - set body [uplevel 1 [list info body $command]] - if {[string match "*$prefix*$suffix*" $body]} { - set prefixposn [string first "$prefix" $body] - set pkgposn [expr {$prefixposn + [string length $prefix]}] - #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] - set suffixposn [string first $suffix $body $pkgposn] - return [string range $body $pkgposn $suffixposn-1] - } else { - return unspecified - } - } else { - if {[info commands tcl::info::cmdtype] ne ""} { - #tcl9 and maybe some tcl 8.7s ? - switch -- [tcl::info::cmdtype $command] { - native { - return builtin - } - default { - return undetermined - } - } - } else { - return undetermined - } - } - } -} -namespace eval commandstack::renamed_commands {} -namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place - -namespace eval commandstack { - namespace export {[a-z]*} - proc help {} { - return { - - } - } - - proc debug {{on_off {}}} { - variable debug - if {$on_off eq ""} { - return $debug - } else { - if {[string is boolean -strict $debug]} { - set debug [expr {$on_off && 1}] - return $debug - } - } - } - - proc get_stack {command} { - variable all_stacks - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - return [dict get $all_stacks $command] - } else { - return [list] - } - } - - #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. - #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? - #e.g if renaming builtin 'package' - this command is generally called 'a lot' - proc get_next_command {command renamer tokenid} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] - if {$posn > -1} { - set record [lindex $stack $posn] - return [dict get $record implementation] - } else { - error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" - } - } else { - return $command - } - } - proc basecall {command args} { - variable all_stacks - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {[llength $stack]} { - set rec1 [lindex $stack 0] - tailcall [dict get $rec1 implementation] {*}$args - } else { - tailcall $command {*}$args - } - } else { - tailcall $command {*}$args - } - } - - - #review. - # defaults to calling namespace - but can be arbitrary string - proc rename_command {args} { - #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames - # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack - # - if {[lindex $args 0] eq "-renamer"} { - set renamer [lindex $args 1] - set arglist [lrange $args 2 end] - } else { - set renamer "" - set arglist $args - } - if {[llength $arglist] != 3} { - error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" - } - lassign $arglist command procargs procbody - - set command [uplevel 1 [list namespace which $command]] - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - variable all_stacks - variable known_renamers - variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. - if {$renamer eq ""} { - set renamer [uplevel 1 [list namespace current]] - } - if {$renamer ni $known_renamers} { - lappend known_renamers $renamer - dict set renamer_command_tokens [list $renamer $command] 0 - } - - #TODO - reduce emissions to stderr - flag for debug? - - #e.g packageTrace and packageSuppress packages use this convention. - set nextinfo [uplevel 1 [list\ - apply {{command renamer procbody} { - #todo - munge dash so we can make names in renamed_commands separable - # {- _dash_} ? - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] - set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. - set do_rename 0 - if {[llength [info procs $command]] || [llength [info commands $next_target]]} { - #$command is not the standard builtin - something has replaced it, could be ourself. - set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] - set munged_next_implementor [string map {:: _ns_} $next_implementor] - #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. - if {[dict exists $::commandstack::all_stacks $command]} { - set comstacks [dict get $::commandstack::all_stacks $command] - } else { - set comstacks [list] - } - set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') - if {[llength $this_renamer_previous_entries]} { - if {$next_implementor eq $renamer} { - #previous renamer was us. Rather than assume our job is done.. compare the implementations - #don't rename if immediate predecessor is same code. - #set topstack [lindex $comstacks end] - #set next_impl [dict get $topstack implementation] - set current_body [info body $command] - lassign [commandstack::lib::split_body $current_body] _ current_code - set current_code [string trim $current_code] - set new_code [string trim $procbody] - if {$current_code eq $new_code} { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." - puts stderr [::commandstack::show_stack $command] - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." - puts stdout "----------" - puts stdout "$current_code" - puts stdout "----------" - puts stdout "$new_code" - puts stdout "----------" - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" - puts stderr - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } elseif {$next_implementor in $::commandstack::known_renamers} { - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {builtin}} { - #native/builtin could still have been renamed - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {unspecified undetermined}} { - #could be a standard tcl proc, or from application or package - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } else { - puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - #_originalcommand_ - #assume builtin/original - set next_implementor original - #rename $command $next_target - set do_rename 1 - } - #There are of course other ways in which $command may have been renamed - but we can't detect. - set token [list $command $renamer $tokenid] - return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] - } } $command $renamer $procbody] - ] - - - variable debug - if $debug { - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" - } else { - #assume this is the original - puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" - } - } - - #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) - #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) - set new_record [dict create\ - token [dict get $nextinfo token]\ - renamer $renamer\ - next_implementor [dict get $nextinfo next_implementor]\ - next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ - implementation [dict get $nextinfo next_target]\ - ] - if {![dict get $nextinfo do_rename]} { - #review - puts stderr "no rename performed" - return [dict create implementation ""] - } - catch {rename ::commandstack::temp::testproc ""} - set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { - #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) - set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. - set COMMANDSTACKNEXT [%next_getter%] - ## - }] - set final_procbody "$nextinit$procbody" - #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command - #(e.g due to invalid argument specifiers) - proc ::commandstack::temp::testproc $procargs $final_procbody - uplevel 1 [list rename $command [dict get $nextinfo next_target]] - uplevel 1 [list rename ::commandstack::temp::testproc $command] - dict lappend all_stacks $command $new_record - - - return $new_record - } - - #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer - #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost - #todo - removal of all entries pertaining to a particular renamer - #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? - - #remove by token, or by commandname if called from same context as original rename_command - #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. - #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. - #similarly a nonexistant token or renamer will not remove anything and will just return the current stack - proc remove_rename {token_or_command} { - if {[llength $token_or_command] == 3} { - #is token - lassign $token_or_command command renamer tokenid - } elseif {[llength $token_or_command] == 2} { - #command and renamer only supplied - lassign $token_or_command command renamer - set tokenid "" - } elseif {[llength $token_or_command] == 1} { - #is command name only - set command $token_or_command - set renamer [uplevel 1 [list namespace current]] - set tokenid "" - } - set command [uplevel 1 [list namespace which $command]] - variable all_stacks - variable known_renamers - if {$renamer ni $known_renamers} { - error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" - } - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {$tokenid ne ""} { - #token_or_command is a token as returned within the rename_command result dictionary - #search first dict value - set doomed_posn [lsearch -index 1 $stack $token_or_command] - } else { - #search second dict value - set matches [lsearch -all -index 3 $stack $renamer] - set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer - } - if {$doomed_posn ne "" && $doomed_posn > -1} { - set doomed_record [lindex $stack $doomed_posn] - if {[llength $stack] == ($doomed_posn + 1)} { - #last on stack - put the implemenation from the doomed_record back as the actual command - uplevel #0 [list rename $command ""] - uplevel #0 [list rename [dict get $doomed_record implementation] $command] - } elseif {[llength $stack] > ($doomed_posn + 1)} { - #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed - set rewrite_posn [expr {$doomed_posn + 1}] - set rewrite_record [lindex $stack $rewrite_posn] - - if {[dict get $rewrite_record next_implementor] ne $renamer} { - puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" - } else { - uplevel #0 [list rename [dict get $rewrite_record implementation] ""] - } - dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] - #don't update next_getter - it always refers to self - dict set rewrite_record implementation [dict get $doomed_record implementation] - lset stack $rewrite_posn $rewrite_record - dict set all_stacks $command $stack - } - set stack [lreplace $stack $doomed_posn $doomed_posn] - dict set all_stacks $command $stack - - } - return $stack - } - return [list] - } - - proc show_stack {{commandname_glob *}} { - variable all_stacks - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } - if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { - #punk pipeline also needed for patterns - return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] - } else { - set result "" - set matchedkeys [dict keys $all_stacks $commandname_glob] - #don't try to calculate widest on empty list - if {[llength $matchedkeys]} { - set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] - set indent [string repeat " " [expr {$widest + 3}]] - set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide - set padkey [string repeat " " 20] - foreach k $matchedkeys { - append result "$k = " - set i 0 - foreach stackmember [dict get $all_stacks $k] { - if {$i > 0} { - append result "\n$indent" - } - append result [string range "$i " 0 4] " = " - set j 0 - dict for {k v} $stackmember { - if {$j > 0} { - append result "\n$indent2" - } - set displaykey [string range "$k$padkey" 0 20] - append result "$displaykey = $v" - incr j - } - incr i - } - append result \n - } - } - return $result - } - } - - #review - #document when this is to be called. Wiping stacks without undoing renames seems odd. - proc Delete_stack {command} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - dict unset all_stacks $command - return 1 - } else { - return 1 - } - } - - #can be used to temporarily put a stack aside - should manually rename back when done. - #review - document how/when to use. example? intention? - proc Rename_stack {oldname newname} { - variable all_stacks - if {[dict exists $all_stacks $oldname]} { - if {[dict exists $all_stacks $newname]} { - error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" - } else { - #set stackval [dict get $all_stacks $oldname] - #dict unset all_stacks $oldname - #dict set all_stacks $newname $stackval - dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] - } - } - } -} - - - - - - - - -namespace eval commandstack::lib { - proc splitx {str {regexp {[\t \r\n]+}}} { - #snarfed from tcllib textutil::splitx to avoid the dependency - # Bugfix 476988 - if {[string length $str] == 0} { - return {} - } - if {[string length $regexp] == 0} { - return [::split $str ""] - } - if {[regexp $regexp {}]} { - return -code error "splitting on regexp \"$regexp\" would cause infinite loop" - } - - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - foreach {subStart subEnd} $submatch break - foreach {matchStart matchEnd} $match break - incr matchStart -1 - incr matchEnd - lappend list [string range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [string range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [string range $str $start end] - return $list - } - proc split_body {procbody} { - set marker "##" - set header "" - set code "" - set found_marker 0 - foreach ln [split $procbody \n] { - if {!$found_marker} { - if {[string trim $ln] eq $marker} { - set found_marker 1 - } else { - append header $ln \n - } - } else { - append code $ln \n - } - } - if {$found_marker} { - return [list $header $code] - } else { - return [list "" $procbody] - } - } -} - -package provide commandstack [namespace eval commandstack { - set version 0.3 -}] - - + + +#JMN 2021 - Public Domain +#cooperative command renaming +# +# REVIEW 2024 - code was originally for specific use in packageTrace +# - code should be reviewed for more generic utility. +# - API is obscure and undocumented. +# - unclear if intention was only for builtins +# - consider use of newer 'info cmdtype' - (but need also support for safe interps) +# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. +# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename +#changes: +#2024 +# - mungecommand to support namespaced commands +# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ +#2021-09-18 +# - initial version +# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command +# - They need to be able to load and unload in any order. +# + +#strive for no other package dependencies here. + + +namespace eval commandstack { + variable all_stacks + variable debug + set debug 0 + variable known_renamers [list ::packagetrace ::packageSuppress] + if {![info exists all_stacks]} { + #don't wipe it + set all_stacks [dict create] + } +} + +namespace eval commandstack::util { + #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. + #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace + #A magic comment was chosen as the identifying method. + #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. + + #return unspecified if the command is a proc with a body but no magic comment ID + #return unknown if the command doesn't have a proc body to analyze + #otherwise return the package name identified in the magic comment + proc get_IMPLEMENTOR {command} { + #assert - command has already been resolved to a namespace ie fully qualified + if {[llength [info procs $command]]} { + #look for *IMPLEMENTOR_*! + set prefix IMPLEMENTOR_ + set suffix "!" + set body [uplevel 1 [list info body $command]] + if {[string match "*$prefix*$suffix*" $body]} { + set prefixposn [string first "$prefix" $body] + set pkgposn [expr {$prefixposn + [string length $prefix]}] + #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] + set suffixposn [string first $suffix $body $pkgposn] + return [string range $body $pkgposn $suffixposn-1] + } else { + return unspecified + } + } else { + if {[info commands tcl::info::cmdtype] ne ""} { + #tcl9 and maybe some tcl 8.7s ? + switch -- [tcl::info::cmdtype $command] { + native { + return builtin + } + default { + return undetermined + } + } + } else { + return undetermined + } + } + } +} +namespace eval commandstack::renamed_commands {} +namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place + +namespace eval commandstack { + namespace export {[a-z]*} + proc help {} { + return { + + } + } + + proc debug {{on_off {}}} { + variable debug + if {$on_off eq ""} { + return $debug + } else { + if {[string is boolean -strict $debug]} { + set debug [expr {$on_off && 1}] + return $debug + } + } + } + + proc get_stack {command} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + return [dict get $all_stacks $command] + } else { + return [list] + } + } + + #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. + #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? + #e.g if renaming builtin 'package' - this command is generally called 'a lot' + proc get_next_command {command renamer tokenid} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] + if {$posn > -1} { + set record [lindex $stack $posn] + return [dict get $record implementation] + } else { + error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" + } + } else { + return $command + } + } + proc basecall {command args} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {[llength $stack]} { + set rec1 [lindex $stack 0] + tailcall [dict get $rec1 implementation] {*}$args + } else { + tailcall $command {*}$args + } + } else { + tailcall $command {*}$args + } + } + + + #review. + # defaults to calling namespace - but can be arbitrary string + proc rename_command {args} { + #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames + # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack + # + if {[lindex $args 0] eq "-renamer"} { + set renamer [lindex $args 1] + set arglist [lrange $args 2 end] + } else { + set renamer "" + set arglist $args + } + if {[llength $arglist] != 3} { + error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" + } + lassign $arglist command procargs procbody + + set command [uplevel 1 [list namespace which $command]] + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + variable all_stacks + variable known_renamers + variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. + if {$renamer eq ""} { + set renamer [uplevel 1 [list namespace current]] + } + if {$renamer ni $known_renamers} { + lappend known_renamers $renamer + dict set renamer_command_tokens [list $renamer $command] 0 + } + + #TODO - reduce emissions to stderr - flag for debug? + + #e.g packageTrace and packageSuppress packages use this convention. + set nextinfo [uplevel 1 [list\ + apply {{command renamer procbody} { + #todo - munge dash so we can make names in renamed_commands separable + # {- _dash_} ? + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] + set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. + set do_rename 0 + if {[llength [info procs $command]] || [llength [info commands $next_target]]} { + #$command is not the standard builtin - something has replaced it, could be ourself. + set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] + set munged_next_implementor [string map {:: _ns_} $next_implementor] + #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. + if {[dict exists $::commandstack::all_stacks $command]} { + set comstacks [dict get $::commandstack::all_stacks $command] + } else { + set comstacks [list] + } + set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') + if {[llength $this_renamer_previous_entries]} { + if {$next_implementor eq $renamer} { + #previous renamer was us. Rather than assume our job is done.. compare the implementations + #don't rename if immediate predecessor is same code. + #set topstack [lindex $comstacks end] + #set next_impl [dict get $topstack implementation] + set current_body [info body $command] + lassign [commandstack::lib::split_body $current_body] _ current_code + set current_code [string trim $current_code] + set new_code [string trim $procbody] + if {$current_code eq $new_code} { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [::commandstack::show_stack $command] + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." + puts stdout "----------" + puts stdout "$current_code" + puts stdout "----------" + puts stdout "$new_code" + puts stdout "----------" + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" + puts stderr + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } elseif {$next_implementor in $::commandstack::known_renamers} { + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {builtin}} { + #native/builtin could still have been renamed + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {unspecified undetermined}} { + #could be a standard tcl proc, or from application or package + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } else { + puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + #_originalcommand_ + #assume builtin/original + set next_implementor original + #rename $command $next_target + set do_rename 1 + } + #There are of course other ways in which $command may have been renamed - but we can't detect. + set token [list $command $renamer $tokenid] + return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] + } } $command $renamer $procbody] + ] + + + variable debug + if {$debug} { + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" + } else { + #assume this is the original + puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" + } + } + + #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) + #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) + set new_record [dict create\ + token [dict get $nextinfo token]\ + renamer $renamer\ + next_implementor [dict get $nextinfo next_implementor]\ + next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ + implementation [dict get $nextinfo next_target]\ + ] + if {![dict get $nextinfo do_rename]} { + #review + puts stderr "no rename performed" + return [dict create implementation ""] + } + catch {rename ::commandstack::temp::testproc ""} + set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { + #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) + set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. + set COMMANDSTACKNEXT [%next_getter%] + ## + }] + set final_procbody "$nextinit$procbody" + #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command + #(e.g due to invalid argument specifiers) + proc ::commandstack::temp::testproc $procargs $final_procbody + uplevel 1 [list rename $command [dict get $nextinfo next_target]] + uplevel 1 [list rename ::commandstack::temp::testproc $command] + dict lappend all_stacks $command $new_record + + + return $new_record + } + + #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer + #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost + #todo - removal of all entries pertaining to a particular renamer + #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? + + #remove by token, or by commandname if called from same context as original rename_command + #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. + #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. + #similarly a nonexistant token or renamer will not remove anything and will just return the current stack + proc remove_rename {token_or_command} { + if {[llength $token_or_command] == 3} { + #is token + lassign $token_or_command command renamer tokenid + } elseif {[llength $token_or_command] == 2} { + #command and renamer only supplied + lassign $token_or_command command renamer + set tokenid "" + } elseif {[llength $token_or_command] == 1} { + #is command name only + set command $token_or_command + set renamer [uplevel 1 [list namespace current]] + set tokenid "" + } + set command [uplevel 1 [list namespace which $command]] + variable all_stacks + variable known_renamers + if {$renamer ni $known_renamers} { + error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" + } + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {$tokenid ne ""} { + #token_or_command is a token as returned within the rename_command result dictionary + #search first dict value + set doomed_posn [lsearch -index 1 $stack $token_or_command] + } else { + #search second dict value + set matches [lsearch -all -index 3 $stack $renamer] + set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer + } + if {$doomed_posn ne "" && $doomed_posn > -1} { + set doomed_record [lindex $stack $doomed_posn] + if {[llength $stack] == ($doomed_posn + 1)} { + #last on stack - put the implemenation from the doomed_record back as the actual command + uplevel #0 [list rename $command ""] + uplevel #0 [list rename [dict get $doomed_record implementation] $command] + } elseif {[llength $stack] > ($doomed_posn + 1)} { + #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed + set rewrite_posn [expr {$doomed_posn + 1}] + set rewrite_record [lindex $stack $rewrite_posn] + + if {[dict get $rewrite_record next_implementor] ne $renamer} { + puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" + } else { + uplevel #0 [list rename [dict get $rewrite_record implementation] ""] + } + dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] + #don't update next_getter - it always refers to self + dict set rewrite_record implementation [dict get $doomed_record implementation] + lset stack $rewrite_posn $rewrite_record + dict set all_stacks $command $stack + } + set stack [lreplace $stack $doomed_posn $doomed_posn] + dict set all_stacks $command $stack + + } + return $stack + } + return [list] + } + + proc show_stack {{commandname_glob *}} { + variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } + if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { + #punk pipeline also needed for patterns + return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] + } else { + set result "" + set matchedkeys [dict keys $all_stacks $commandname_glob] + #don't try to calculate widest on empty list + if {[llength $matchedkeys]} { + set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] + set indent [string repeat " " [expr {$widest + 3}]] + set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide + set padkey [string repeat " " 20] + foreach k $matchedkeys { + append result "$k = " + set i 0 + foreach stackmember [dict get $all_stacks $k] { + if {$i > 0} { + append result "\n$indent" + } + append result [string range "$i " 0 4] " = " + set j 0 + dict for {k v} $stackmember { + if {$j > 0} { + append result "\n$indent2" + } + set displaykey [string range "$k$padkey" 0 20] + append result "$displaykey = $v" + incr j + } + incr i + } + append result \n + } + } + return $result + } + } + + #review + #document when this is to be called. Wiping stacks without undoing renames seems odd. + proc Delete_stack {command} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + dict unset all_stacks $command + return 1 + } else { + return 1 + } + } + + #can be used to temporarily put a stack aside - should manually rename back when done. + #review - document how/when to use. example? intention? + proc Rename_stack {oldname newname} { + variable all_stacks + if {[dict exists $all_stacks $oldname]} { + if {[dict exists $all_stacks $newname]} { + error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" + } else { + #set stackval [dict get $all_stacks $oldname] + #dict unset all_stacks $oldname + #dict set all_stacks $newname $stackval + dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] + } + } + } +} + + + + + + + + +namespace eval commandstack::lib { + proc splitx {str {regexp {[\t \r\n]+}}} { + #snarfed from tcllib textutil::splitx to avoid the dependency + # Bugfix 476988 + if {[string length $str] == 0} { + return {} + } + if {[string length $regexp] == 0} { + return [::split $str ""] + } + if {[regexp $regexp {}]} { + return -code error "splitting on regexp \"$regexp\" would cause infinite loop" + } + + set list {} + set start 0 + while {[regexp -start $start -indices -- $regexp $str match submatch]} { + foreach {subStart subEnd} $submatch break + foreach {matchStart matchEnd} $match break + incr matchStart -1 + incr matchEnd + lappend list [string range $str $start $matchStart] + if {$subStart >= $start} { + lappend list [string range $str $subStart $subEnd] + } + set start $matchEnd + } + lappend list [string range $str $start end] + return $list + } + proc split_body {procbody} { + set marker "##" + set header "" + set code "" + set found_marker 0 + foreach ln [split $procbody \n] { + if {!$found_marker} { + if {[string trim $ln] eq $marker} { + set found_marker 1 + } else { + append header $ln \n + } + } else { + append code $ln \n + } + } + if {$found_marker} { + return [list $header $code] + } else { + return [list "" $procbody] + } + } +} + +package provide commandstack [namespace eval commandstack { + set version 0.3 +}] + + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm index 5d63ffef..970e47da 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm @@ -20,7 +20,7 @@ #[manpage_begin fauxlink_module_fauxlink 0 0.1.1] #[copyright "2024"] #[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] -#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] +#[moddesc {.fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] #[require fauxlink] #[keywords symlink faux fake shortcut toml] #[description] @@ -29,18 +29,19 @@ #[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as #[para] archiving and packaging systems. #[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. -#[para] format of name #.fxlnk +#[para] format of name #.fauxlink #[para] where can be empty - then the effective nominal name is the tail of the +#[para] The file extension must be .fauxlink or .fxlnk #[para] The + symbol substitutes for forward-slashes. #[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) #[para] We deliberately treat higher % sequences literally. #[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls. #[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 #[para] e.g a link to a file file#A.txt in parent dir could be: -#[para] file%23A.txt#..+file%23A.txt.fxlnk -#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk +#[para] file%23A.txt#..+file%23A.txt.fauxlink +#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fauxlink #[para] The can be unrelated to the actual target -#[para] e.g datafile.dat#..+file%23A.txt.fxlnk +#[para] e.g datafile.dat#..+file%23A.txt.fauxlink #[para] This system has no filesystem support - and must be completely application driven. #[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. #[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined @@ -63,9 +64,9 @@ #https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded # ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. #Using fauxlink - a link would be: -# "my-program-files#++server+c+Program%20Files.fxlnk" +# "my-program-files#++server+c+Program%20Files.fauxlink" #If we needed the old-style literal %20 it would become -# "my-program-files#++server+c+Program%2520Files.fxlnk" +# "my-program-files#++server+c+Program%2520Files.fauxlink" # # The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) # e.g @@ -296,12 +297,12 @@ namespace eval fauxlink { set is_fauxlink 0 #we'll process anyway - but return the result wrapped #This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent - #(e.g blindly processing all files in a folder that is normally only .fxlnk files - but then something added that happens + #(e.g blindly processing all files in a folder that is normally only .fauxlink files - but then something added that happens # to have # characters in it) #It also means if someone really wants to use the fauxlink semantics on a different file type # - they can - but just have to access the results differently and take that (minor) risk. #error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" - set err_extra "\nnonstandard extension '$extension_name' for fauxlink. Check that the call to fauxlink::resolve was deliberate" + set err_extra "\nnonstandard extension '$extension_name' for fauxlink. (expected .fxlnk or .fauxlink) Check that the call to fauxlink::resolve was deliberate" } else { set is_fauxlink 1 set err_extra "" @@ -318,7 +319,7 @@ namespace eval fauxlink { #if there are 4 parts - the 3rd part is a tagset where each tag begins with @ #and each subsequent part is a comment. Empty comments are stripped from the comments list #A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @ - #e.g name.txt#path#@tag1@tag2#test###.fxlnk + #e.g name.txt#path#@tag1@tag2#test###.fauxlink #has a name, a target, 2 tags and one comment #check namespec already has required chars encoded diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.5.tm index 4c88cb16..ebcf579e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.5.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.5.tm @@ -1,6411 +1,6411 @@ -package require dictutils -package provide metaface [namespace eval metaface { - variable version - set version 1.2.5 -}] - - - - -#example datastructure: -#$_ID_ -#{ -#i -# { -# this -# { -# {16 ::p::16 item ::>x {}} -# } -# role2 -# { -# {17 ::p::17 item ::>y {}} -# {18 ::p::18 item ::>z {}} -# } -# } -#context {} -#} - -#$MAP -#invocantdata {16 ::p::16 item ::>x {}} -#interfaces {level0 -# { -# api0 {stack {123 999}} -# api1 {stack {333}} -# } -# level0_default api0 -# level1 -# { -# } -# level1_default {} -# } -#patterndata {patterndefaultmethod {}} - - -namespace eval ::p::predator {} -#temporary alternative to ::p::internals namespace. -# - place predator functions here until ready to replace internals. - - -namespace eval ::p::snap { - variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks. -} - - - - -# not called directly. Retrieved using 'info body ::p::predator::getprop_template' -#review - why use a proc instead of storing it as a string? -proc ::p::predator::getprop_template {_ID_ args} { - set OID [lindex [dict get $_ID_ i this] 0 0] - if {"%varspace%" eq ""} { - set ns ::p::${OID} - } else { - if {[string match "::*" "%varspace%"]} { - set ns "%varspace%" - } else { - set ns ::p::${OID}::%varspace% - } - } - - - if {[llength $args]} { - #lassign [lindex $invocant 0] OID alias itemCmd cmd - if {[array exists ${ns}::o_%prop%]} { - #return [set ${ns}::o_%prop%($args)] - if {[llength $args] == 1} { - return [set ::p::${OID}::o_%prop%([lindex $args 0])] - } else { - return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]] - } - } else { - set val [set ${ns}::o_%prop%] - - set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] - if {$rType eq "object"} { - #return [$val . item {*}$args] - return [$val {*}$args] - } else { - #treat as list? - return [lindex $val $args] - } - } - } else { - return [set ${ns}::o_%prop%] - } -} - - -proc ::p::predator::getprop_template_immediate {_ID_ args} { - if {[llength $args]} { - if {[array exists %ns%::o_%prop%]} { - return [set %ns%::o_%prop%($args)] - } else { - set val [set %ns%::o_%prop%] - set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] - if {$rType eq "object"} { - #return [$val . item {*}$args] - #don't assume defaultmethod named 'item'! - return [$val {*}$args] - } else { - #treat as list? - return [lindex $val $args] - } - } - } else { - return [set %ns%::o_%prop%] - } -} - - - - - - - - -proc ::p::predator::getprop_array {_ID_ prop args} { - set OID [lindex [dict get $_ID_ i this] 0 0] - - #upvar 0 ::p::${OID}::o_${prop} prop - #1st try: assume array - if {[catch {array get ::p::${OID}::o_${prop}} result]} { - #treat as list (why?) - #!review - if {[info exists ::p::${OID}::o_${prop}]} { - array set temp [::list] - set i 0 - foreach element ::p::${OID}::o_${prop} { - set temp($i) $element - incr i - } - set result [array get temp] - } else { - error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" - } - } - return $result -} - -proc ::p::predator::setprop_template {prop _ID_ args} { - set OID [lindex [dict get $_ID_ i this] 0 0] - if {"%varspace%" eq ""} { - set ns ::p::${OID} - } else { - if {[string match "::*" "%varspace%"]} { - set ns "%varspace%" - } else { - set ns ::p::${OID}::%varspace% - } - } - - - if {[llength $args] == 1} { - #return [set ::p::${OID}::o_%prop% [lindex $args 0]] - return [set ${ns}::o_%prop% [lindex $args 0]] - - } else { - if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { - #treat attempt to perform indexed write to nonexistant var, same as indexed write to array - - #2 args - single index followed by a value - if {[llength $args] == 2} { - return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] - } else { - #multiple indices - #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] - return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] - } - } else { - #treat as list - return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] - } - } -} - -#-------------------------------------- -#property read & write traces -#-------------------------------------- - - -proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} { - - #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' " - - #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain. - - if {[llength $idx]} { - if {[llength $idx] == 1} { - set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx] - } else { - lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx] - } - return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value - } else { - if {![info exists $refname]} { - set $refname [$get_cmd $_ID_ {*}$indices] - } else { - set newval [$get_cmd $_ID_ {*}$indices] - if {[set $refname] ne $newval} { - set $refname $newval - } - } - return - } -} - - - - -proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} { - #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname - #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" - - - #derive the name of the write command from the ref var. - set indices [lassign [split [namespace tail $refname] +] prop] - - - #assert - we will never have both a list in indices and an idx value - if {[llength $indices] && ($idx ne "")} { - #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x - #review - are there any datastructures which would/should allow this? - #this assertion is really just here as a sanity check for now - error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" - } - - #upvar #0 ::p::${OID}::_meta::map MAP - #puts "-->propref_trace_write map: $MAP" - - #temporarily deactivate refsync trace - #puts stderr -->1>--removing_trace_o_${field} -### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] - - #we need to catch, and re-raise any error that we may receive when writing the property - # because we have to reinstate the propvar_write_TraceHandler after the call. - #(e.g there may be a propertywrite handler that deliberately raises an error) - - set excludesync_refs $refname - set cmd ::p::${OID}::(SET)$prop - - - set f_error 0 - if {[catch { - - if {![llength $indices]} { - if {[string length $idx]} { - $cmd $_ID_ $idx [set ${refname}($idx)] - #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] - - } else { - $cmd $_ID_ [set $refname] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] - } - } else { - #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" - $cmd $_ID_ {*}$indices [set $refname] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices - } - - } result]} { - set f_error 1 - } - - - - - #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write - #reactivate refsync trace - #puts stderr "****** reactivating refsync trace on o_$field" - #puts stderr -->2>--reactivating_trace_o_${field} - ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] - - - if {$f_error} { - #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. - # ? return -code error $errMsg ? -errorinfo - - #!quick n dirty - #error $errorMsg - return -code error -errorinfo $::errorInfo $result - } else { - return $result - } -} - - - - - -proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { - #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'" - #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array') - - set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set - - #set updated_value [::p::predator::getprop_array $prop $_ID_] - #puts stderr "-->array_Trace updated_value:$updated_value" - if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} { - puts stderr "-->propref_trace_array error $errm" - array set $refname {} - } - - #return value ignored for -} - - -#-------------------------------------- -# -proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - - - #don't rely on variable name passed by trace - may have been 'upvar'ed - set refvar ::p::${OID}::_ref::__OBJECT - - #puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar" - - set iflist [dict get $MAP interfaces level0] - - set plist [list] - - #!todo - get propertylist from cache on object(?) - foreach IFID [lreverse $iflist] { - dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { - #lassign $pdef v - if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} { - if {[array exists ::p::${OID}::o_${prop}]} { - lappend plist $prop [array get ::p::${OID}::o_${prop}] - } else { - #ignore - array only represents properties that have been set. - #error "property $v is not set" - #!todo - unset corresponding items in $refvar if needed? - } - } - } - } - array set $refvar $plist -} - - -proc ::p::predator::object_read_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - #don't rely on variable name passed by trace. - set refvar ::p::${OID}::_ref::__OBJECT - - #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" - - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set IID "" - foreach id [lreverse $iflist] { - if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - - if {[string length $IID]} { - #property - if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { - puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" - } - } else { - #method - error "property '$idx' not found" - } -} - - -proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd - - #!todo - ??? - - if {![llength [info commands ::p::${OID}::$idx]]} { - error "no such method or property: '$idx'" - } else { - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set found 0 - foreach id [lreverse $iflist] { - if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set found 1 - break - } - } - - if {$found} { - unset ::p::${OID}::o_$idx - } else { - puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" - } - } -} - - -proc ::p::predator::object_write_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - #don't rely on variable name passed by trace. - set refvar ::p::${OID}::_ref::__OBJECT - #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" - - - if {![llength [info commands ::p::${OID}::$idx]]} { - #!todo - create new property in interface upon attempt to write to non-existant? - # - or should we require some different kind of object-reference for that? - array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx - error "no such method or property: '$idx'" - } else { - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set IID "" - foreach id [lreverse $iflist] { - if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - - #$IID is now topmost interface in default iStack which has this property - - if {[string length $IID]} { - #write to defined property - - ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] - } else { - #!todo - allow write of method body back to underlying object? - #attempted write to 'method' ..undo(?) - array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx - error "cannot write to method '$idx'" - #for now - disallow - } - } - -} - - - -proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} { - #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname - - set refindices [lassign [split [namespace tail $refname] +] prop] - #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop - #if there is no PropertyUnset command - we unset the underlying variable directly - - trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] - - - if {[catch { - - #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value - #i.e - if {[llength $refindices] && [string length $idx]} { - puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" - error "unexpected call to propref_trace_unset" - } - - - upvar #0 ::p::${OID}::_meta::map MAP - - set iflist [dict get $MAP interfaces level0] - #find topmost interface containing this $prop - set IID "" - foreach id [lreverse $iflist] { - if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - if {![string length $IID]} { - error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" - } - - - - - - - if {[string length $idx]} { - #eval "$_alias ${unset_}$field $idx" - #what happens to $refindices??? - - - #!todo varspace - - if {![llength $refindices]} { - #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - unset ::p::${OID}::o_${prop}($idx) - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx - } - - - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx - } else { - #assert - won't get here - error 1a - - } - - } else { - if {[llength $refindices]} { - #error 2a - #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - #review - what about list-type property? - #if {[array exists ::p::${OID}::o_${prop}]} ??? - unset ::p::${OID}::o_${prop}($refindices) - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices - } - - - - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices - - - } else { - #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - #ref is not of form prop+x etc and no idx in the trace - this is a plain unset - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - unset ::p::${OID}::o_${prop} - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" - } - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} - - } - } - - - - - } errM]} { - #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" - set ruler [string repeat - 80] - puts stderr "\t$ruler" - puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - puts stderr "\t$ruler" - puts stderr $errM - puts stderr "\t$ruler" - - } else { - #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - #puts stderr "*@*@*@*@ end propref_trace_unset - no error" - } - - trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] - - -} - - - - -proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} { - - #Do not use 'info exists' (avoid triggering read trace) - use info vars - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - #puts " **> lappending '::p::REF::${OID}::$prop'" - lappend refvars ::p::${OID}::_ref::$prop - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] - - - - if {[string length $triggeringRef]} { - set idx [lsearch -exact $refvars $triggeringRef] - if {$idx >= 0} { - set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] - } - } - if {![llength $refvars]} { - #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" - return - } - - - #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset - # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" - if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { - #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" - puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" - } - - - puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " - - - - upvar $vtraced SYNCVARIABLE - - - #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars - array set traces [::list] - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - if {$ops in {read write unset array}} { - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } - } - } - } - - - - - if {[array exists SYNCVARIABLE]} { - - #underlying variable is an array - we are presumably unsetting just an element - set vtracedIsArray 1 - } else { - #!? maybe the var was an array - but it's been unset? - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - #some things we don't want to repeat for each refvar in case there are lots of them.. - - #set triggeringRefIdx $vidx - - if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { - set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] - } else { - set triggering_indices [list] - } - - - - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "--- unset branch refvar:$refvar" - - - - if {[llength $vidx]} { - #trace called with an index - must be an array - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #!todo - add test - if {$vidx eq [lrange [split $reftail +] 1 end]} { - #unset if indices match - error "untested, possibly unused branch spuds1" - #puts "1111111111111111111111111" - unset $refvar - } - } else { - #test exists - #!todo - document which one - - #see if we succeeded in unsetting this element in the underlying variables - #(may have been blocked by a PropertyUnset body) - set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] - #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" - if {$element_exists} { - #do nothing it wasn't actually unset - } else { - #puts "JJJJJ unsetting ${refvar}($vidx)" - unset ${refvar}($vidx) - } - } - } - - - - - - } else { - - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #check indices of triggering refvar match this refvars indices - - - if {$reftail eq [namespace tail $triggeringRef]} { - #!todo - add test - error "untested, possibly unused branch spuds2" - #puts "222222222222222222" - unset $refvar - } else { - - #error "untested - branch spuds2a" - - - } - - } else { - #!todo -add test - #reference is directly to property var - error "untested, possibly unused branch spuds3" - #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? - puts "\t33333333333333333333" - - if {[string length $triggeringRefIdx]} { - unset $refvar($triggeringRefIdx) - } - } - } - - } - - - - - #!todo - understand. - #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" - #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" - trace add variable $rv $ops $cmd - } - } - - - - - -} - - -proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} { - - upvar $vtraced SYNCVARIABLE - - set refvars [::list] - #Do not use 'info exists' (avoid triggering read trace) - use info vars - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - lappend refvars ::p::${OID}::_ref::$prop - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] - - - - #short_circuit breaks unset traces for array elements (why?) - - - if {![llength $refvars]} { - #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" - return - } else { - puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" - } - - if {[catch { - - - - #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars - array set traces [::list] - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - if {$ops in {read write unset array}} { - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } - } - } - } - - - - - if {[array exists SYNCVARIABLE]} { - - #underlying variable is an array - we are presumably unsetting just an element - set vtracedIsArray 1 - } else { - #!? maybe the var was an array - but it's been unset? - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - #some things we don't want to repeat for each refvar in case there are lots of them.. - set triggeringRefIdx $vidx - - - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "--- unset branch refvar:$refvar" - - - - if {[llength $vidx]} { - #trace called with an index - must be an array - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #!todo - add test - if {$vidx eq [lrange [split $reftail +] 1 end]} { - #unset if indices match - error "untested, possibly unused branch spuds1" - #puts "1111111111111111111111111" - unset $refvar - } - } else { - #test exists - #!todo - document which one - - #see if we succeeded in unsetting this element in the underlying variables - #(may have been blocked by a PropertyUnset body) - set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] - #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" - if {$element_exists} { - #do nothing it wasn't actually unset - } else { - #puts "JJJJJ unsetting ${refvar}($vidx)" - unset ${refvar}($vidx) - } - } - } - - - - - - } else { - - foreach refvar $refvars { - set reftail [namespace tail $refvar] - unset $refvar - - } - - } - - - - - #!todo - understand. - #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" - #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" - trace add variable $rv $ops $cmd - } - } - - } errM]} { - set ruler [string repeat * 80] - puts stderr "\t$ruler" - puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" - puts stderr "\t$ruler" - puts stderr $::errorInfo - puts stderr "\t$ruler" - - } - -} - -proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} { - error hmmmmm - upvar $vtraced SYNCVARIABLE - #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " - set refvars [::list] - - #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references - #assert triggeringRef is in the list - if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { - error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" - } - set refposn [lsearch -exact $refvars $triggeringRef] - #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 - set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] - if {![llength $refvars]} { - #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" - return [list refs_updates [list]] - } - - #suppress the propref_trace_* traces on all refvars - array set traces [::list] - array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." - #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync - #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? - #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - - - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } else { - #all other traces are 'external' - lappend external_traces($rv) $tinfo - #trace remove variable $rv $ops $cmd - } - - } - } - #-------------------------------------------------------------------------------------------------------------------------- - if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { - if {![info exists SYNCVARIABLE]} { - error "WARNING: REVIEW why does $vartraced not exist here?" - } - #either the underlying variable is an array - # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern - set treat_vtraced_as_array 1 - } else { - set treat_vtraced_as_array 0 - } - - set refs_updated [list] - set refs_deleted [list] ;#unset due to index no longer being relevant - if {$treat_vtraced_as_array} { - foreach refvar $refvars { - #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" - set refvar_tail [namespace tail $refvar] - if {[string match "${prop}+*" $refvar_tail]} { - #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y - set ref_indices [lrange [split $refvar_tail +] 1 end] - if {[llength $indices]} { - if {[llength $indices] == 1} { - if {[lindex $ref_indices 0] eq [lindex $indices 0]} { - #error "untested xxx-a" - set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] - lappend refs_updated $refvar - } else { - #test exists - #error "xxx-ok single index" - #updating a different part of the property - nothing to do - } - } else { - #nested index - if {[lindex $ref_indices 0] eq [lindex $indices 0]} { - if {[llength $ref_indices] == 1} { - #error "untested xxx-b1" - set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] - } else { - #assert llength $ref_indices > 1 - #NOTE - we cannot test index equivalence reliably/simply just by comparing indices - #compare by value - - if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { - #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" - if {[set $refvar] ne $possiblyNewVal} { - set $refvar $possiblyNewVal - } - } else { - #fail to retrieve underlying value corrsponding to these $indices - unset $refvar - } - } - } else { - #test exists - #error "untested xxx-ok deepindex" - #updating a different part of the property - nothing to do - } - } - } else { - error "untested xxx-c" - - } - - } else { - #refvar to update is plain e.g ::p::${OID}::_ref::${prop} - if {[llength $indices]} { - if {[llength $indices] == 1} { - set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] - } else { - lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] - } - lappend refs_updated $refvar - } else { - error "untested yyy" - set $refvar $SYNCVARIABLE - } - } - } - } else { - #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) - # - foreach refvar $refvars { - #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" - set refvar_tail [namespace tail $refvar] - if {[string match "${prop}+*" $refvar_tail]} { - #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y - set ref_indices [lrange [split $refvar_tail +] 1 end] - - if {[llength $indices]} { - #see if this update would affect this curried ref - #1st see if we can short-circuit our comparison based on numeric-indices - if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { - #both sets of indices are purely numeric (no end end-1 etc) - set rlen [llength $ref_indices] - set ilen [llength $indices] - set minlen [expr {min($rlen,$ilen)}] - set matched_firstfew_indices 1 ;#assume the best - for {set i 0} {$i < $minlen} {incr i} { - if {[lindex $ref_indices $i] ne [lindex $indices $i]} { - break ;# - } - } - if {!$matched_firstfew_indices} { - #update of this refvar not required - #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" - break ;#break to next refvar in the foreach loop - } - } - #failed to short-circuit - - #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here - set newval [lindex $SYNCVARIABLE $ref_indices] - if {[set $refvar] ne $newval} { - set $refvar $newval - lappend refs_updated $refvar - } - - } else { - #we must be updating the entire variable - so this curried ref will either need to be updated or unset - set newval [lindex $SYNCVARIABLE $ref_indices] - if {[set ${refvar}] ne $newval} { - set ${refvar} $newval - lappend refs_updated $refvar - } - } - } else { - #refvar to update is plain e.g ::p::${OID}::_ref::${prop} - if {[llength $indices]} { - #error "untested zzz-a" - set newval [lindex $SYNCVARIABLE $indices] - if {[lindex [set $refvar] $indices] ne $newval} { - lset ${refvar} $indices $newval - lappend refs_updated $refvar - } - } else { - if {[set ${refvar}] ne $SYNCVARIABLE} { - set ${refvar} $SYNCVARIABLE - lappend refs_updated $refvar - } - } - - } - - } - } - #-------------------------------------------------------------------------------------------------------------------------- - - #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - if {$rv ni $refs_deleted} { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - } - foreach rv [array names external_traces] { - if {$rv ni $refs_deleted} { - foreach tinfo $external_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - #trace add variable $rv $ops $cmd - } - } - } - - - return [list updated_refs $refs_updated] -} - -#purpose: update all relevant references when context variable changed directly -proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { - #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. - #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler - - upvar $vtraced SYNCVARIABLE - #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" - set t_info [trace vinfo $vtraced] - foreach t_spec $t_info { - set t_ops [lindex $t_spec 0] - if {$op in $t_ops} { - puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" - } - } - - #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- - #vtype = array | array-item | list | simple - - set refvars [::list] - - ############################ - #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! - #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) - #The alternative 'info vars' does not trigger traces - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - #puts " **> lappending '::p::REF::${OID}::$prop'" - lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - } - ############################ - - #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references - - - if {![llength $refvars]} { - #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" - return - } - - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars - array set predator_traces [::list] - #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. - #ie for something like 'trace add variable someref {write read array} somefunc' - # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace - array set external_read_traces [::list] ;#pure read traces the library user may have added - array set external_readetc_traces [::list] ;#read + something else traces the library user may have added - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - #if {$ops in {read write unset array}} {} - - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend predator_traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } else { - #other traces - # puts "##trace $tinfo" - if {"read" in $ops} { - if {[llength $ops] == 1} { - #pure read - - lappend external_read_traces($rv) $tinfo - trace remove variable $rv $ops $cmd - } else { - #mixed operation trace - remove and reinstall without the 'read' - lappend external_readetc_traces($rv) $tinfo - set other_ops [lsearch -all -inline -not $ops "read"] - trace remove variable $rv $ops $cmd - #reinstall trace for non-read operations only - trace add variable $rv $other_ops $cmd - } - } - } - } - } - - - if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { - #either the underlying variable is an array - # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern - set vtracedIsArray 1 - } else { - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" - #puts "**write*********** refvars: $refvars" - - #!todo? unroll foreach into multiple foreaches within ifs? - #foreach refvar $refvars {} - - - #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" - if {[string length $vidx]} { - #indexable - if {$vtracedIsArray} { - - foreach refvar $refvars { - #puts stderr " - - a refvar $refvar vidx: $vidx" - set tail [namespace tail $refvar] - if {[string match "${prop}+*" $tail]} { - #refvar is curried - #only set if vidx matches curried index - #!todo -review - set idx [lrange [split $tail +] 1 end] - if {$idx eq $vidx} { - set newval [set SYNCVARIABLE($vidx)] - if {[set $refvar] ne $newval} { - set ${refvar} $newval - } - #puts stderr "=a.1=> updated $refvar" - } - } else { - #refvar is simple - set newval [set SYNCVARIABLE($vidx)] - if {![info exists ${refvar}($vidx)]} { - #new key for this array - #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " - array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] - } else { - set oldval [set ${refvar}($vidx)] - if {$oldval ne $newval} { - #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " - array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] - } - } - #puts stderr "=a.2=> updated ${refvar} $vidx" - } - } - - - - } else { - - - foreach refvar $refvars { - upvar $refvar internal_property_reference - #puts stderr " - - b vidx: $vidx" - - #!? could be object not list?? - #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? - #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) - #There would still be an edge case of an initial write of a list of objects of length 1. - if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { - error "untested review!" - #the o_prop is object-shaped - #assumes object has a defaultmethod which accepts indices - set newval [[set $SYNCVARIABLE] {*}$vidx] - - } else { - set newval [lindex $SYNCVARIABLE {*}$vidx] - #if {[set $refvar] ne $newval} { - # set $refvar $newval - #} - if {$internal_property_reference ne $newval} { - set internal_property_reference $newval - } - - } - #puts stderr "=b=> updated $refvar" - } - - - } - - - - } else { - #no vidx - - if {$vtracedIsArray} { - - - foreach refvar $refvars { - set targetref_tail [namespace tail $refvar] - set targetref_is_indexed [string match "${prop}+*" $targetref_tail] - - - #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" - if {$targetref_is_indexed} { - #curried array item ref of the form ${prop}+x or ${prop}+x+y etc - - #unindexed write on a property that is acting as an array.. - - #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. - - #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). - # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. - puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" - } else { - #How do we know what to write to array ref? - puts stderr "\tc.2 WARNING: unimplemented/unused?" - #error no_tests_for_branch - - #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation - #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate - array unset ${refvar} - array set ${refvar} [array get SYNCVARIABLE] - } - } - - - - } else { - foreach refvar $refvars { - #puts stderr "\t\t_________________[namespace current]" - set targetref_tail [namespace tail $refvar] - upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail - set targetref_is_indexed [string match "${prop}+*" $targetref_tail] - - if {$targetref_is_indexed} { - #puts "XXXXXXXXX vtraced:$vtraced" - #reference curried with index(es) - #we only set indexed refs if value has changed - # - this not required to be consistent with standard list-containing variable traces, - # as normally list elements can't be traced seperately anyway. - # - - - #only bother checking a ref if no setVia index - # i.e some operation on entire variable so need to test synchronisation for each element-ref - set targetref_indices [lrange [split $targetref_tail +] 1 end] - set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] - #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" - if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { - set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal - #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" - } - - - } else { - #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! - - #puts stderr "- d2 set" - #puts "refvar: [set $refvar]" - #puts "SYNCVARIABLE: $SYNCVARIABLE" - - #if {[set $refvar] ne $SYNCVARIABLE} { - # set $refvar $SYNCVARIABLE - #} - if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { - set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE - } - - } - } - - - } - - } - - - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names predator_traces] { - foreach tinfo $predator_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - - foreach rv [array names external_traces] { - foreach tinfo $external_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - - - -} - -# end propvar_write_TraceHandler - - - - - - - - - - - - - - - - -# - -#returns 0 if method implementation not present for interface -proc ::p::predator::method_chainhead {iid method} { - #Interface proc - # examine the existing command-chain - set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex) - set cmdchain [list] - - set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}] - set maxversion 0 - #loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob. - foreach test [lsort -dictionary $candidates] { - set c [namespace tail $test] - if {[regexp $re $c _match version]} { - lappend cmdchain $c - if {$version > $maxversion} { - set maxversion $version - } - } - } - return $maxversion -} - - - - - -#this returns a script that upvars vars for all interfaces on the calling object - -# - must be called at runtime from a method -proc ::p::predator::upvar_all {_ID_} { - #::set OID [lindex $_ID_ 0 0] - ::set OID [::lindex [::dict get $_ID_ i this] 0 0] - ::set decl {} - #[set ::p::${OID}::_meta::map] - #[dict get [lindex [dict get $_ID_ i this] 0 1] map] - - ::upvar #0 ::p::${OID}::_meta::map MAP - #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" - #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] - - ::foreach ifid [dict get $MAP interfaces level0] { - if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} { - ::array unset nsvars - ::array set nsvars [::list] - ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { - ::set varspace [::dict get $vinfo varspace] - ::lappend nsvars($varspace) $vname - } - #nsvars now contains vars grouped by varspace. - - ::foreach varspace [::array names nsvars] { - if {$varspace eq ""} { - ::set ns ::p::${OID} - } else { - if {[::string match "::*" $varspace]} { - ::set ns $varspace - } else { - ::set ns ::p::${OID}::$varspace - } - } - - ::append decl "namespace upvar $ns " - ::foreach vname [::set nsvars($varspace)] { - ::append decl "$vname $vname " - } - ::append decl " ;\n" - } - ::array unset nsvars - } - } - ::return $decl -} - -#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator) -proc ::p::predator::runtime_vardecls {} { - set result "::eval \[::p::predator::upvar_all \$_ID_\]" - #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" - - #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" - #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" - #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" - return $result -} - - - - - - -#OBSOLETE!(?) - todo - move stuff out of here. -proc ::p::predator::compile_interface {IFID caller_ID_} { - upvar 0 ::p::${IFID}:: IFACE - - #namespace eval ::p::${IFID} { - # namespace ensemble create - #} - - #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables - - namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces - - #set varDecls {} - #if {[llength $o_variables]} { - # #puts "*********!!!! $vlist" - # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] " - # foreach vdef $o_variables { - # append varDecls "[lindex $vdef 0] [lindex $vdef 0] " - # } - # append varDecls \n - #} - - #runtime gathering of vars from other interfaces. - #append varDecls [runtime_vardecls] - - set varDecls [runtime_vardecls] - - - - #implement methods - - #!todo - avoid globs on iface array? maintain list of methods in another slot? - #foreach {n mname} [array get IFACE m-1,name,*] {} - - - #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. - - - - #implement property getters/setters/unsetters - #'setter' overrides - #pw short for propertywrite - foreach {n property} [array get IFACE pw,name,*] { - if {[string length $property]} { - #set property [lindex [split $n ,] end] - - #!todo - next_script - #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] - - set maxversion [::p::predator::method_chainhead $IFID (SET)$property] - set chainhead [expr {$maxversion + 1}] - set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 - - set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? - - set body $IFACE(pw,body,$property) - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set body $varDecls\n[dict get $processed body] - #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" - } - - #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - - - set maxversion [::p::predator::method_chainhead $IFID $property] - set headid [expr {$maxversion + 1}] - - proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body - - interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid - - #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body - } - } - #'unset' overrides - - dict for {property handler_info} $o_propertyunset_handlers { - - set body [dict get $handler_info body] - set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array - - set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (UNSET)$property.$headid - - set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? - - - - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set body $varDecls\n[dict get $processed body] - #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body" - - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - - - - #implement - #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) - if {[string trim $arraykeypattern] eq ""} { - set arraykeypattern "_dontcare_" - } - proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body - - - #chainhead pointer - interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid - } - - - - interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) - - #the usual case will have no destructor - so use info exists to check. - - if {[info exists ::p::${IFID}::_iface::o_destructor_body]} { - #!todo - chained destructors (support @next@). - #set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID] - set next NEXT - - set body [set ::p::${IFID}::_iface::o_destructor_body] - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set body $varDecls\n[dict get $processed body] - #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body" - } - #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body] - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - - proc ::p::${IFID}::___system___destructor _ID_ $body - } - - - if {[info exists o_unknown]} { - #use 'apply' somehow? - interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown - - #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] - } - - - return -} - - - - - - - -#'info args' - assuming arbitrary chain of 'interp aliases' -proc ::p::predator::command_info_args {cmd} { - if {[llength [set next [interp alias {} $cmd]]]} { - set curriedargs [lrange $next 1 end] - - if {[catch {set arglist [info args [lindex $next 0]]}]} { - set arglist [command_info_args [lindex $next 0]] - } - #trim curriedargs - return [lrange $arglist [llength $curriedargs] end] - } else { - info args $cmd - } -} - - -proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { - if {[llength $args]} { - tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args - } else { - if {[llength $nextArgs] > 1} { - set argVals [::list] - set i 0 - foreach arg [lrange $nextArgs 1 end] { - upvar 1 $arg $i - if {$arg eq "args"} { - #need to check if 'args' is actually available in caller - if {[info exists $i]} { - set argVals [concat $argVals [set $i]] - } - } else { - lappend argVals [set $i] - } - } - tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals - } else { - tailcall ::p::${IFID}::_iface::$mname $_ID_ - } - } -} - -#---------------------------------------------------------------------------------------------- -proc ::p::predator::next_script {IFID method caller caller_ID_} { - - if {$caller eq "(CONSTRUCTOR).1"} { - return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}] - } elseif {$caller eq "$method.1"} { - #delegate to next interface lower down the stack which has a member named $method - return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] - } elseif {[string match "(GET)*.2" $caller]} { - # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. - - #jmn - set prop [string trimright $caller 1234567890] - set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing . - - if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} { - #return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}] - return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] - } else { - #we can actually have a property read without a property or a method of that name - but it could also match the name of a method. - # (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something) - return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] - } - } elseif {[string match "(SET)*.2" $caller]} { - return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] - } else { - #this branch will also handle (SET)*.x and (GET)*.x where x >2 - - #puts stdout "............next_script IFID:$IFID method:$method caller:$caller" - set callerid [string range $caller [string length "$method."] end] - set nextid [expr {$callerid - 1}] - - if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} { - #not a proc directly on this interface - presumably an alias made by something like linkcopy_interface. - #puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid" - set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid] - } - - return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] - } -} - -proc ::p::predator::do_next_if {_ID_ IFID method args} { - #puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' (((" - - #set invocants [dict get $_ID_ i] - #set this_invocantdata [lindex [dict get $invocants this] 0] - #lassign $this_invocantdata OID this_info - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set interfaces [dict get $MAP interfaces level0] - set patterninterfaces [dict get $MAP interfaces level1] - - set L0_posn [lsearch $interfaces $IFID] - if {$L0_posn == -1} { - error "(::p::predator::do_next_if) called with interface not present at level0 for this object" - } elseif {$L0_posn > 0} { - #set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack - set lower_interfaces [lrange $interfaces 0 $L0_posn-1] - - foreach if_sub [lreverse $lower_interfaces] { - if {[string match "(GET)*" $method]} { - #do not test o_properties here! We need to call even if there is no underlying property on this interface - #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) - # relevant test: higher_order_propertyread_chaining - return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - } elseif {[string match "(SET)*" $method]} { - #must be called even if there is no matching $method in o_properties - return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - } elseif {[string match "(UNSET)*" $method]} { - #review untested - #error "do_next_if (UNSET) untested" - #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'" - return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - - } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} { - if {[llength $args]} { - #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args" - - #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args - - #!todo - handle case where llength $args is less than number of args for subinterface command - #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set) - - #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature) - set head [interp alias {} ::p::${if_sub}::_iface::$method] - set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc - set argx [list] - foreach a $nextArgs { - lappend argx "\$a" - } - - #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared - - if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} { - tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args - } else { - #todo - upvars required for tail end of arglist - tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args - } - - } else { - #auto-set: upvar vars from calling scope - #!todo - robustify? alias not necessarily matching command name.. - set head [interp alias {} ::p::${if_sub}::_iface::$method] - - - set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc - if {[llength $nextArgs] > 1} { - set argVals [::list] - set i 0 - foreach arg [lrange $nextArgs 1 end] { - upvar 1 $arg $i - if {$arg eq "args"} { - #need to check if 'args' is actually available in caller - if {[info exists $i]} { - set argVals [concat $argVals [set $i]] - } - } else { - lappend argVals [set $i] - } - } - #return [$head $_ID_ {*}$argVals] - tailcall $head $_ID_ {*}$argVals - } else { - #return [$head $_ID_] - tailcall $head $_ID_ - } - } - } elseif {$method eq "(CONSTRUCTOR)"} { - #chained constructors will only get args if the @next@ caller explicitly provided them. - puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" - #return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args] - xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args - } - } - #no interfaces in the iStack contained a matching method. - return - } else { - #no further interfaces in this iStack - return - } -} - - -#only really makes sense for (CONSTRUCTOR) calls. -#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class. -proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { - #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" - - #set invocants [dict get $_ID_ i] - #set this_invocant [lindex [dict get $invocants this] 0] - #lassign $this_invocant OID this_info - #set OID [lindex [dict get $invocants this] 0 0] - #upvar #0 ::p::${OID}::_meta::map map - #lassign [lindex $map 0] OID alias itemCmd cmd - - - set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] - upvar #0 ::p::${caller_OID}::_meta::map callermap - - #set interfaces [lindex $map 1 0] - set patterninterfaces [dict get $callermap interfaces level1] - - set L0_posn [lsearch $patterninterfaces $IFID] - if {$L0_posn == -1} { - error "do_next_pattern_if called with interface not present at level1 for this object" - } elseif {$L0_posn > 0} { - - - set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] - - foreach if_sub [lreverse $lower_interfaces] { - if {$method eq "(CONSTRUCTOR)"} { - #chained constructors will only get args if the @next@ caller explicitly provided them. - #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" - tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args - } - } - #no interfaces in the iStack contained a matching method. - return - } else { - #no further interfaces in this iStack - return - } -} - - - - - -#------------------------------------------------------------------------------------------------ - - - - - -#------------------------------------------------------------------------------------- -####################################################### -####################################################### -####################################################### -####################################################### -####################################################### -####################################################### -####################################################### - - -#!todo - can we just call new_object somehow to create this? - - #until we have a version of Tcl that doesn't have 'creative writing' scope issues - - # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. - # (see http://mini.net/tcl/1030 'Dangers of creative writing') -namespace eval ::p::-1 { - #namespace ensemble create - - namespace eval _ref {} - namespace eval _meta {} - - namespace eval _iface { - variable o_usedby - variable o_open - variable o_constructor - variable o_variables - variable o_properties - variable o_methods - variable o_definition - variable o_varspace - variable o_varspaces - - array set o_usedby [list i0 1] ;#!todo - review - #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? - - set o_open 1 - set o_constructor [list] - set o_variables [list] - set o_properties [dict create] - set o_methods [dict create] - array set o_definition [list] - set o_varspace "" - set o_varspaces [list] - } -} - - -# - -#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}] -interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}] - - -upvar #0 ::p::-1::_iface::o_definition def - - -#! concatenate -> compose ?? -dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}} -proc ::p::-1::Concatenate {_ID_ target args} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - if {![string match "::*" $target]} { - if {[set ns [uplevel 1 {namespace current}]] eq "::"} { - set target ::$target - } else { - set target ${ns}::$target - } - } - #add > character if not already present - set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] - set _target [string map {::> ::} $target] - - set ns [namespace qualifiers $target] - if {$ns eq ""} { - set ns "::" - } else { - namespace eval $ns {} - } - - if {![llength [info commands $target]]} { - #degenerate case - target does not exist - #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone' - #review - should be 'Copy' so it has object state from namespaces and variables? - return [::p::-1::Clone $_ID_ $target {*}$args] - - #set TARGETMAP [::p::predator::new_object $target] - #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd - - } else { - #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] - set TARGETMAP [$target --] - - lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd - - #Merge lastmodified(?) level0 and level1 interfaces. - - } - - return $target -} - - - -#Object's Base-Interface proc with itself as curried invocant. -#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant -#namespace eval ::p::-1 {namespace export Create} -dict set ::p::-1::_iface::o_methods Define {arglist definitions} -#define objects in one step -proc ::p::-1::Define {_ID_ definitions} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias default_method cmd - set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces - set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces - - #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack - #set IFID0 [lindex $interfaces 0] - #set IFID1 [lindex $patterns 0] ;#1st pattern - - #set IFID_TOP [lindex $interfaces end] - set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] - - #set ns ::p::${OID} - - #set script [string map [list %definitions% $definitions] { - # if {[lindex [namespace path] 0] ne "::p::-1"} { - # namespace path [list ::p::-1 {*}[namespace path]] - # } - # %definitions% - # namespace path [lrange [namespace path] 1 end] - # - #}] - - set script [string map [list %id% $_ID_ %definitions% $definitions] { - set ::p::-1::temp_unknown [namespace unknown] - - namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] - - - #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] - - - %definitions% - - - namespace unknown ${::p::-1::temp_unknown} - return - }] - - - - #uplevel 1 $script ;#this would run the script in the global namespace - #run script in the namespace of the open interface, this allows creating of private helper procs - #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack - #namespace inscope ::p::${OID} $script - namespace eval ::p::${OID} $script - #return $cmd -} - - -proc ::p::predator::redirect {func args} { - - #todo - review tailcall - tests? - if {![llength [info commands ::p::-1::$func]]} { - #error "invalid command name \"$func\"" - tailcall uplevel 1 [list ::unknown $func {*}$args] - } else { - tailcall uplevel 1 [list ::p::-1::$func {*}$args] - } -} - - -#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review. -dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}} -proc ::p::-1::Construct {_ID_ argpairs body args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set interfaces [dict get $MAP interfaces level0] - set iid_top [lindex $interfaces end] - namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace - - set ARGSETTER {} - foreach {argname argval} $argpairs { - append ARGSETTER "set $argname $argval\n" - } - #$_self (VIOLATE) $ARGSETTER$body - - set body $ARGSETTER\n$body - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls\n[dict get $processed body] - # puts stderr "\t runtime_vardecls in Construct $varDecls" - } - - set next "\[error {next not implemented}\]" - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - - #namespace eval ::p::${iid_top} $body - - #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] - #does this handle Varspace before constructor? - return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] -} - - - - - -#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects -namespace eval ::p::3 {} -proc ::p::3::_create {child {OID "-2"}} { - #puts stderr "::p::3::_create $child $OID" - set _child [string map {::> ::} $child] - if {$OID eq "-2"} { - #set childmapdata [::p::internals::new_object $child] - #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] - set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - } else { - set child_ID $OID - #set _childmap [::p::internals::new_object $child "" $child_ID] - ::p::internals::new_object $child "" $child_ID - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - } - - #-------------- - - set oldinterfaces [dict get $CHILDMAP interfaces] - dict set oldinterfaces level0 [list 2] - set modifiedinterfaces $oldinterfaces - dict set CHILDMAP interfaces $modifiedinterfaces - - #-------------- - - - - - #puts stderr ">>>> creating alias for ::p::$child_ID" - #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" - - #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! - #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] - #puts stderr ">>>[interp alias {} ::p::$child_ID]" - - - - #--------------- - namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties - foreach method [dict keys $o_methods] { - #todo - change from interp alias to context proc - interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method - } - #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] - #implement property even if interface already compiled because we need to create defaults for each new child obj. - # also need to add alias on base interface - #make sure we are only implementing properties from the current CREATOR - dict for {prop pdef} $o_properties { - #lassign $pdef prop default - interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop - interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop - - } - ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] - #--------------- - #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" - return $child -} - -#configure -prop1 val1 -prop2 val2 ... -dict set ::p::-1::_iface::o_methods Configure {arglist args} -proc ::p::-1::Configure {_ID_ args} { - - #!todo - add tests. - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd this - - if {![expr {([llength $args] % 2) == 0}]} { - error "expected even number of Configure args e.g '-property1 value1 -property2 value2'" - } - - #Do a separate loop to check all the arguments before we run the property setting loop - set properties_to_configure [list] - foreach {argprop val} $args { - if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} { - error "expected Configure args in the form: '-property1 value1 -property2 value2'" - } - lappend properties_to_configure [string range $argprop 1 end] - } - - #gather all valid property names for all level0 interfaces in the relevant interface stack - set valid_property_names [list] - set iflist [dict get $MAP interfaces level0] - foreach id [lreverse $iflist] { - set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]] - foreach if_prop $interface_property_names { - if {$if_prop ni $valid_property_names} { - lappend valid_property_names $if_prop - } - } - } - - foreach argprop $properties_to_configure { - if {$argprop ni $valid_property_names} { - error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names" - } - } - - set top_IID [lindex $iflist end] - #args ok - go ahead and set all properties - foreach {prop val} $args { - set property [string range $prop 1 end] - #------------ - #don't use property ref unnecessarily - leaves property refs hanging around which traces need to update - #ie don't do this here: set [$this . $property .] $val - #------------- - ::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val] - } - return -} - - - - - - -dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid} -proc ::p::-1::AddPatternInterface {_ID_ iid} { - #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" - if {![string is integer -strict $iid]} { - error "adding interface by name not yet supported. Please use integer id" - } - - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - #lassign [lindex $invocant 0] OID alias itemCmd cmd - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces - - - - #it is theoretically possible to have the same interface present multiple times in an iStack. - # #!todo -review why/whether this is useful. should we disallow it and treat as an error? - - lappend existing_ifaces $iid - #lset map {1 1} $existing_ifaces - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 $existing_ifaces - dict set MAP interfaces $extracted_sub_dict - - #lset invocant {1 1} $existing_ifaces - -} - - -#!todo - update usedby ?? -dict set ::p::-1::_iface::o_methods AddInterface {arglist iid} -proc ::p::-1::AddInterface {_ID_ iid} { - #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" - if {![string is integer -strict $iid]} { - error "adding interface by name not yet supported. Please use integer id" - } - - - lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. - set this_invocant [lindex $list_of_invocants_for_role_this 0] - - lassign $this_invocant OID _etc - - upvar #0 ::p::${OID}::_meta::map MAP - set existing_ifaces [dict get $MAP interfaces level0] - - lappend existing_ifaces $iid - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 $existing_ifaces - dict set MAP interfaces $extracted_sub_dict - return [dict get $extracted_sub_dict level0] -} - - - -# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module. -# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist -# and 'CreateOverlay' for the case where the target/child object already exists. -# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence, -# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object. -# 'CreateNew' will raise an error if the target already exists -# 'CreateOverlay' will raise an error if the target object does not exist. -# 'Create' will work in either case. Creating the target if necessary. - - -#simple form: -# >somepattern .. Create >child -#simple form with arguments to the constructor: -# >somepattern .. Create >child arg1 arg2 etc -#complex form - specify more info about the target (dict keyed on childobject name): -# >somepattern .. Create {>child {-id 1}} -#or -# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] -#complex form - with arguments to the contructor: -# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc -dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}} -proc ::p::-1::Create {_ID_ target_spec args} { - #$args are passed to constructor - if {[llength $target_spec] ==1} { - set child $target_spec - set targets [list $child {}] - } else { - set targets $target_spec - } - - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - set invocants [dict get $_ID_ i] - set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) - - foreach {child target_spec_dict} $targets { - #puts ">>>::p::-1::Create $_ID_ $child $args <<<" - - - - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - - - - - #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID" - - #child should already be fully ns qualified (?) - #ensure it is has a pattern-object marker > - #puts stderr ".... $child (nsqual: [namespace qualifiers $child])" - - - lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd - set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces - set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces - #puts "parent: $OID -> child:$child Patterns $patterns" - - #todo - change to dict of interface stacks - set IFID0 [lindex $interfaces 0] - set IFID1 [lindex $patterns 0] ;#1st pattern - - #upvar ::p::${OID}:: INFO - - if {![string match {::*} $child]} { - if {[set ns [uplevel 1 {namespace current}]] eq "::"} { - set child ::$child - } else { - set child ${ns}::$child - } - } - - - #add > character if not already present - set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >] - set _child [string map {::> ::} $child] - - set ns [namespace qualifiers $child] - if {$ns eq ""} { - set ns "::" - } else { - namespace eval $ns {} - } - - - #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls. - set new_interfaces [list] - - if {![llength $patterns]} { - ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child" - #lappend patterns [::p::internals::new_interface $OID] - - #lset invocant {1 1} $patterns - ##update our command because we changed the interface list. - #set IFID1 [lindex $patterns 0] - - #set patterns [list [::p::internals::new_interface $OID]] - - #set patterns [list [::p::internals::new_interface]] - - #set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id - #set patterns [list [set iid [incr ::p::ID]]] - set patterns [list [set iid [::p::get_new_object_id]]] - - #--------- - #set iface [::p::>interface .. Create ::p::ifaces::>$iid] - #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid - - #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation - lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid] - - #--------- - - #puts "??> p::>interface .. Create ::p::ifaces::>$iid" - #puts "??> [::p::ifaces::>$iid --]" - #set [$iface . UsedBy .] - } - set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] - - #if {![llength [info commands $child]]} {} - - if {[namespace which $child] eq ""} { - #normal case - target/child does not exist - set is_new_object 1 - - if {[dict exists $target_spec_dict -id]} { - set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]] - } else { - set childmapdata [::p::internals::new_object $child] - } - lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - - - - #child initially uses parent's level1 interface as it's level0 interface - # child has no level1 interface until PatternMethods or PatternProperties are added - # (or applied via clone; or via create with a parent with level2 interface) - #set child_IFID $IFID1 - - #lset CHILDMAP {1 0} [list $IFID1] - #lset CHILDMAP {1 0} $patterns - - set extracted_sub_dict [dict get $CHILDMAP interfaces] - dict set extracted_sub_dict level0 $patterns - dict set CHILDMAP interfaces $extracted_sub_dict - - #why write back when upvared??? - #review - set ::p::${child_ID}::_meta::map $CHILDMAP - - #::p::predator::remap $CHILDMAP - - #interp alias {} $child {} ::p::internals::predator $CHILDMAP - - #set child_IFID $IFID1 - - #upvar ::p::${child_ID}:: child_INFO - - #!todo review - #set n ::p::${child_ID} - #if {![info exists ${n}::-->PATTERN_ANCHOR]} { - # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" - # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack - # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" - # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] - #} - - set ifaces_added $patterns - - } else { - #overlay/mixin case - target/child already exists - set is_new_object 0 - - #set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1] - set childmapdata [$child --] - - - #puts stderr " *** $cmd .. Create -> target $child already exists!!!" - #puts " **** CHILDMAP: $CHILDMAP" - #puts " ****" - - #puts stderr " ---> Properties: [$child .. Properties . names]" - #puts stderr " ---> Methods: [$child .. Properties . names]" - - lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - - #set child_IFID [lindex $CHILDMAP 1 0 end] - #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} { - # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] - # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP - #} - ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces - #::p::merge_interface $IFID1 $child_IFID - - - set existing_interfaces [dict get $CHILDMAP interfaces level0] - set ifaces_added [list] - foreach p $patterns { - if {$p ni $existing_interfaces} { - lappend ifaces_added $p - } - } - - if {[llength $ifaces_added]} { - #lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added] - set extracted_sub_dict [dict get $CHILDMAP interfaces] - dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added] - dict set CHILDMAP interfaces $extracted_sub_dict - #set ::p::${child_ID}::_meta::map $CHILDMAP ;#why? - #::p::predator::remap $CHILDMAP - } - } - - #do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty - if {$parent_patterndefaultmethod ne ""} { - set child_defaultmethod $parent_patterndefaultmethod - set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata] - lset CHILD_INVOCANTDATA 2 $child_defaultmethod - dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA - #update the child's _ID_ - interp alias {} $child_alias {} ;#first we must delete it - interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}] - - #! object_command was initially created as the renamed alias - so we have to do it again - rename $child_alias $child - trace add command $child rename [list $child .. Rename] - } - #!todo - review - dont we already have interp alias entries for every method/prop? - #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" - - - - - - set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call. - - - - #------------------------------------------------------------------------------------ - #create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail. - # - All variables under the namespace - not just those declared as Variables or Properties - # - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces. - # - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write. - - #NOTE - do not use the objectID as the sole identifier for the snapshot namespace. - # - there may be multiple active snapshots for a single object if it overlays itself during a constructor, - # and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call. - # - we will use an ever-increasing snapshotid to form part of ns_snap - set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create. - - #!todo - this should look at child namespaces (recursively?) - #!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces. - # (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace) - - namespace eval $ns_snap {} - foreach vname [info vars ::p::${child_ID}::*] { - set shortname [namespace tail $vname] - if {[array exists $vname]} { - array set ${ns_snap}::${shortname} [array get $vname] - } elseif {[info exists $vname]} { - set ${ns_snap}::${shortname} [set $vname] - } else { - #variable exists without value (e.g created by 'variable' command) - namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist' - } - } - #------------------------------------------------------------------------------------ - - - - - - - - - - #puts "====>>> ifaces_added $ifaces_added" - set idx 0 - set idx_count [llength $ifaces_added] - set highest_constructor_IFID "" - foreach IFID $ifaces_added { - incr idx - #puts "--> adding iface $IFID " - namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces - - if {[llength $o_varspaces]} { - foreach vs $o_varspaces { - #ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work. - if {[string match "::*" $vs]} { - namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all. - } else { - namespace eval ::p::${child_ID}::$vs {} - } - } - } - - if {$IFID != 2} { - #>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list. - if {![info exists o_usedby(i$child_ID)]} { - set o_usedby(i$child_ID) $child_alias - } - - #compile and close the interface only if it is shared - if {$o_open} { - ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_ - set o_open 0 - } - } - - - - package require struct::set - - set propcmds [list] - foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] { - set cmd [namespace tail $cmd] - #may contain multiple results for same prop e.g (GET)x.3 - set cmd [string trimright $cmd 0123456789] - set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals - lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. - } - set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. - #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. - foreach property $propcmds { - #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n" - interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces - interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property - } - - set propcmds [list] - foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] { - set cmd [namespace tail $cmd] - #may contain multiple results for same prop e.g (GET)x.3 - set cmd [string trimright $cmd 0123456789] - set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals - lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. - } - set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. - #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. - foreach property $propcmds { - interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces - } - - - foreach method [dict keys $o_methods] { - set arglist [dict get $o_methods $method arglist] - set argvals "" - foreach argspec $arglist { - if {[llength $argspec] == 2} { - set a [lindex $argspec 0] - } else { - set a $argspec - } - - if {$a eq "args"} { - append argvals " \{*\}\$args" - } else { - append argvals " \$$a" - } - } - set argvals [string trimleft $argvals] - - #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method - - #this proc directly on the object is not *just* a forwarding proc - # - it provides a context in which the 'uplevel 1' from the running interface proc runs - #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) - - #proc calls the method in the interface - which is an interp alias to the head of the implementation chain - - - proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst { - ::p::${IFID}::_iface::$method \$_ID_ $argvals - }] - - #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] { - # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ - #}] - - - } - - #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] - - #implement property even if interface already compiled because we need to create defaults for each new child obj. - # also need to add alias on base interface - #make sure we are only implementing properties from the current CREATOR - dict for {prop pdef} $o_properties { - set varspace [dict get $pdef varspace] - if {![string length $varspace]} { - set ns ::p::${child_ID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${child_ID}::$varspace - } - } - if {[dict exists $pdef default]} { - if {![info exists ${ns}::o_$prop]} { - #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) - set ${ns}::o_$prop [dict get $pdef default] - } - } - #! May be replaced by a method with the same name - if {$prop ni [dict keys $o_methods]} { - interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop - } - interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop - interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop - } - - - - #variables - #foreach vdef $o_variables { - # if {[llength $vdef] == 2} { - # #there is a default value defined. - # lassign $vdef v default - # if {![info exists ::p::${child_ID}::$v]} { - # set ::p::${child_ID}::$v $default - # } - # } - #} - dict for {vname vdef} $o_variables { - if {[dict exists $vdef default]} { - #there is a default value defined. - set varspace [dict get $vdef varspace] - if {$varspace eq ""} { - set ns ::p::${child_ID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${child_ID}::$varspace - } - } - set ${ns}::$vname [dict get $vdef default] - } - } - - - #!todo - review. Write tests for cases of multiple constructors! - - #We don't want to the run constructor for each added interface with the same set of args! - #run for last one - rely on constructor authors to use @next@ properly? - if {[llength [set ::p::${IFID}::_iface::o_constructor]]} { - set highest_constructor_IFID $IFID - } - - if {$idx == $idx_count} { - #we are processing the last interface that was added - now run the latest constructor found - if {$highest_constructor_IFID ne ""} { - #at least one interface has a constructor - if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} { - #puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP" - if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} { - set constructor_failure 1 - set constructor_errorInfo $::errorInfo ;#cache it immediately. - break - } - } - } - } - - if {[info exists o_unknown]} { - interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown - interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown - - - #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown - #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] - #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown] - } - } - - if {$constructor_failure} { - if {$is_new_object} { - #is Destroy enough to ensure that no new interfaces or objects were left dangling? - $child .. Destroy - } else { - #object needs to be returned to a sensible state.. - #attempt to rollback all interface additions and object state changes! - puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n" - #remove variables from the object's namespace - which don't exist in the snapshot. - set snap_vars [info vars ${ns_snap}::*] - puts "ns_snap '$ns_snap' vars'${snap_vars}'" - foreach vname [info vars ::p::${child_ID}::*] { - set shortname [namespace tail $vname] - if {"${ns_snap}::$shortname" ni "$snap_vars"} { - #puts "--- >>>>> unsetting $shortname " - unset -nocomplain $vname - } - } - - #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces) - #values of vars may also have Changed - #todo - consider traces? what is the correct behaviour? - # - some application traces may have fired before the constructor error occurred. - # Should the rollback now also trigger traces? - #probably yes. - - #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value - foreach vname $snap_vars { - #puts stdout "@@@@@@@@@@@ restoring $vname" - #flush stdout - - - set shortname [namespace tail $vname] - set target ::p::${child_ID}::$shortname - if {$target in [info vars ::p::${child_ID}::*]} { - set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only' - } else { - set present 0 - } - - if {[array exists $vname]} { - #restore 'array' variable - if {!$present} { - array set $target [array get $vname] - } else { - if {[array exists $target]} { - #unset superfluous elements - foreach key [array names $target] { - if {$key ni [array names $vname]} { - array unset $target $key - } - } - #.. and write only elements that have changed. - foreach key [array names $vname] { - if {[set ${target}($key)] ne [set ${vname}($key)]} { - set ${target}($key) [set ${vname}($key)] - } - } - } else { - #target has been changed to a simple variable - unset it and recreate the array. - unset $target - array set $target [array get $vname] - } - } - } elseif {[info exists $vname]} { - #restore 'simple' variable - if {!$present} { - set $target [set $vname] - } else { - if {[array exists $target]} { - #target has been changed to array - unset it and recreate the simple variable. - unset $target - set $target [set $vname] - } else { - if {[set $target] ne [set $vname]} { - set $target [set $vname] - } - } - } - } else { - #restore 'declared' variable - if {[array exists $target] || [info exists $target]} { - unset -nocomplain $target - } - namespace eval ::p::${child_ID} [list variable $shortname] - } - } - } - namespace delete $ns_snap - return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error - } - namespace delete $ns_snap - - } - - - - return $child -} - -dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} -#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied* -# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*) -# Also: Any 'open' interfaces on the parent become closed on clone! -proc ::p::-1::Clone {_ID_ clone args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set invocants [dict get $_ID_ i] - lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd - - set _cmd [string map {::> ::} $cmd] - set tail [namespace tail $_cmd] - - - #obsolete? - ##set IFID0 [lindex $map 1 0 end] - #set IFID0 [lindex [dict get $MAP interfaces level0] end] - ##set IFID1 [lindex $map 1 1 end] - #set IFID1 [lindex [dict get $MAP interfaces level1] end] - - - if {![string match "::*" $clone]} { - if {[set ns [uplevel 1 {namespace current}]] eq "::"} { - set clone ::$clone - } else { - set clone ${ns}::$clone - } - } - - - set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] - set _clone [string map {::> ::} $clone] - - - set cTail [namespace tail $_clone] - - set ns [namespace qualifiers $clone] - if {$ns eq ""} { - set ns "::" - } - - namespace eval $ns {} - - - #if {![llength [info commands $clone]]} {} - if {[namespace which $clone] eq ""} { - set clonemapdata [::p::internals::new_object $clone] - } else { - #overlay/mixin case - target/clone already exists - #set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1] - set clonemapdata [$clone --] - } - set clone_ID [lindex [dict get $clonemapdata invocantdata] 0] - - upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP - - - #copy patterndata element of MAP straight across - dict set CLONEMAP patterndata [dict get $MAP patterndata] - set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata] - lset CLONE_INVOCANTDATA 2 $parent_defaultmethod - dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA - lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone - - #update the clone's _ID_ - interp alias {} $clone_alias {} ;#first we must delete it - interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}] - - #! object_command was initially created as the renamed alias - so we have to do it again - rename $clone_alias $clone - trace add command $clone rename [list $clone .. Rename] - - - - - #obsolete? - #upvar ::p::${clone_ID}:: clone_INFO - #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. - #upvar ::p::${OID}:: INFO - - - array set clone_INFO [array get INFO] - - array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' - - - #!review! - #if {![catch {set itemCmd $IFACE(m-1,name,item)}]} { - #puts "***************" - #puts "clone" - #parray IFINFO - #puts "***************" - #} - - #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern - - - #clone's interface maps must be a superset of original's - foreach lev {0 1} { - #set parent_ifaces [lindex $map 1 $lev] - set parent_ifaces [dict get $MAP interfaces level$lev] - - #set existing_ifaces [lindex $CLONEMAP 1 $lev] - set existing_ifaces [dict get $CLONEMAP interfaces level$lev] - - set added_ifaces_$lev [list] - foreach ifid $parent_ifaces { - if {$ifid ni $existing_ifaces} { - - #interface must not remain extensible after cloning. - if {[set ::p::${ifid}::_iface::o_open]} { - ::p::predator::compile_interface $ifid $_ID_ - set ::p::${ifid}::_iface::o_open 0 - } - - - - lappend added_ifaces_$lev $ifid - #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. - set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone - } - } - set extracted_sub_dict [dict get $CLONEMAP interfaces] - dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]] - dict set CLONEMAP interfaces $extracted_sub_dict - #lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]] - } - - #interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE) - - - #foreach *added* level0 interface.. - foreach ifid $added_ifaces_0 { - namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown - - - dict for {prop pdef} $o_properties { - #lassign $pdef prop default - if {[dict exists $pdef default]} { - set varspace [dict get $pdef varspace] - if {$varspace eq ""} { - set ns ::p::${clone_ID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${clone_ID}::$varspace - } - } - - if {![info exists ${ns}::o_$prop]} { - #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) - set ${ns}::o_$prop [dict get $pdef default] - } - } - - #! May be replaced by method of same name - if {[namespace which ::p::${clone_ID}::$prop] eq ""} { - interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop - } - interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop - interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop - } - - #variables - dict for {vname vdef} $o_variables { - if {[dict exists $vdef default]} { - set varspace [dict get $vdef varspace] - if {$varspace eq ""} { - set ns ::p::${clone_ID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${clone_ID}::$varspace - } - } - if {![info exists ${ns}::$vname]} { - set ::p::${clone_ID}::$vname [dict get $vdef default] - } - } - } - - - #update the clone object's base interface to reflect the new methods. - #upvar 0 ::p::${ifid}:: IFACE - #set methods [list] - #foreach {key mname} [array get IFACE m-1,name,*] { - # set method [lindex [split $key ,] end] - # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP - # lappend methods $method - #} - #namespace eval ::p::${clone_ID} [list namespace export {*}$methods] - - - foreach method [dict keys $o_methods] { - - set arglist [dict get $o_methods $method arglist] - set argvals "" - foreach argspec $arglist { - if {[llength $argspec] == 2} { - set a [lindex $argspec 0] - } else { - set a $argspec - } - - if {$a eq "args"} { - append argvals " \{*\}\$args" - } else { - append argvals " \$$a" - } - } - set argvals [string trimleft $argvals] - #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method - - - #this proc directly on the object is not *just* a forwarding proc - # - it provides a context in which the 'uplevel 1' from the running interface proc runs - #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) - - #proc calls the method in the interface - which is an interp alias to the head of the implementation chain - proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst { - ::p::${ifid}::_iface::$method \$_ID_ $argvals - }] - - } - #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods] - - - if {[info exists o_unknown]} { - #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown - interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown - interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown - - #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown] - #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown] - - } - - - #2021 - #Consider >parent with constructor that sets height - #.eg >parent .. Constructor height { - # set o_height $height - #} - #>parent .. Create >child 5 - # - >child has height 5 - # now when we peform a clone operation - it is the >parent's constructor that will run. - # A clone will get default property and var values - but not other variable values unless the constructor sets them. - #>child .. Clone >fakesibling 6 - # - >sibling has height 6 - # Consider if >child had it's own constructor created with .. Construct prior to the clone operation. - # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead. - # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining... - # when we now do >sibling .. Create >grandchild - # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild - # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.) - # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild - #(though other arguments can be manually passed) - # #!review - does this make sense? What if we add - # - #constructor for each interface called after properties initialised. - #run each interface's constructor against child object, using the args passed into this clone method. - if {[llength [set constructordef [set o_constructor]]]} { - #error - puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID" - ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args - - } - - } - - - return $clone - -} - - - -interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?) -dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}} -proc ::p::-1::Constructor {_ID_ arglist body} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - #lassign [lindex $invocant 0 ] OID alias itemCmd cmd - - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. - set iface ::p::ifaces::>$iid_top - - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - #set iid_top [::p::get_new_object_id] - - #the >interface constructor takes a list of IDs for o_usedby - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] - - #::p::predator::remap $invocant - } - set IID $iid_top - - namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces - - - # examine the existing command-chain - set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] - set headid [expr {$maxversion + 1}] - set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 - - set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] - - #set varspaces [::pattern::varspace_list] - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] - set body $varDecls\n[dict get $processed body] - #puts stderr "\t runtime_vardecls in Constructor $varDecls" - } - - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - #puts stderr ---- - #puts stderr $body - #puts stderr ---- - - proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body - interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid - - - - set o_constructor [list $arglist $body] - set o_open 1 - - return -} - - - -dict set ::p::-1::_iface::o_methods UsedBy {arglist {}} -proc ::p::-1::UsedBy {_ID_} { - return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby] -} - - -dict set ::p::-1::_iface::o_methods Ready {arglist {}} -proc ::p::-1::Ready {_ID_} { - return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}] -} - - - -dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}} - -#'force' 1 indicates object command & variable will also be removed. -#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var. -#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4) -# -proc ::p::-1::Destroy {_ID_ {force 1}} { - #puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]" - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - - if {$OID eq "null"} { - puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" - return - } - - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - - #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout - - #explicit Destroy - remove traces - #puts ">>TRACES: [trace info variable $cmd]" - #foreach tinfo [trace info variable $cmd] { - # trace remove variable $cmd {*}$tinfo - #} - #foreach tinfo [trace info command $cmd] { - # trace remove command $cmd {*}$tinfo - #} - - - set _cmd [string map {::> ::} $cmd] - - #set ifaces [lindex $map 1] - set iface_stacks [dict get $MAP interfaces level0] - #set patterns [lindex $map 2] - set pattern_stacks [dict get $MAP interfaces level1] - - - - set ifaces $iface_stacks - - - set patterns $pattern_stacks - - - #set i 0 - #foreach iflist $ifaces { - # set IFID$i [lindex $iflist 0] - # incr i - #} - - - set IFTOP [lindex $ifaces end] - - set DESTRUCTOR ::p::${IFTOP}::___system___destructor - #may be a proc, or may be an alias - if {[namespace which $DESTRUCTOR] ne ""} { - set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] - - if {[catch {$DESTRUCTOR $temp_ID_} prob]} { - #!todo - ensure correct calling order of interfaces referencing the destructor proc - - - #!todo - emit destructor errors somewhere - logger? - #puts stderr "underlying proc already removed??? ---> $prob" - #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" - #puts stderr $::errorInfo - #puts stderr "---------------------" - } - } - - - #remove ourself from each interfaces list of referencers - #puts stderr "--- $ifaces" - - foreach var {ifaces patterns} { - - foreach i [set $var] { - - if {[string length $i]} { - if {$i == 2} { - #skip the >ifinfo interface which doesn't maintain a usedby list anyway. - continue - } - - if {[catch { - - upvar #0 ::p::${i}::_iface::o_usedby usedby - - array unset usedby i$OID - - - #puts "\n***>>***" - #puts "IFACE: $i usedby: $usedby" - #puts "***>>***\n" - - #remove interface if no more referencers - if {![array size usedby]} { - #puts " **************** DESTROYING unused interface $i *****" - #catch {namespace delete ::p::$i} - - #we happen to know where 'interface' object commands are kept: - - ::p::ifaces::>$i .. Destroy - - } - - } errMsg]} { - #warning - puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" - } - } - - } - - } - - set ns ::p::${OID} - #puts "-- destroying objects below namespace:'$ns'" - ::p::internals::DestroyObjectsBelowNamespace $ns - #puts "--.destroyed objects below '$ns'" - - - #set ns ::p::${OID}::_sub - #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace - #( ::p::OBJECT::$OID ) - #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" - #::p::internals::DestroyObjectsBelowNamespace $ns - - #same for _meta objects (e.g Methods,Properties collections) - #set ns ::p::${OID}::_meta - #::p::internals::DestroyObjectsBelowNamespace $ns - - - - #foreach obj [info commands ${ns}::>*] { - # #Assume it's one of ours, and ask it to die. - # catch {::p::meta::Destroy $obj} - # #catch {$cmd .. Destroy} - #} - #just in case the user created subnamespaces.. kill objects there too. - #foreach sub [namespace children $ns] { - # ::p::internals::DestroyObjectsBelowNamespace $sub - #} - - - #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value! - #use info commands ::p::${OID}::_ref::* to find all references - including variables never set - #remove variable traces on REF vars - #foreach rv [info vars ::p::${OID}::_ref::*] { - # foreach tinfo [trace info variable $rv] { - # #puts "-->removing traces on $rv: $tinfo" - # trace remove variable $rv {*}$tinfo - # } - #} - - #!todo - write tests - #refs create aliases and variables at the same place - #- but variable may not exist if it was never set e.g if it was only used with info exists - foreach rv [info commands ::p::${OID}::_ref::*] { - foreach tinfo [trace info variable $rv] { - #puts "-->removing traces on $rv: $tinfo" - trace remove variable $rv {*}$tinfo - } - } - - - - - - - - #if {[catch {namespace delete $nsMeta} msg]} { - # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " - #} else { - # #puts stderr "------ -- -- -- -- deleted $nsMeta " - #} - - - #!todo - remove - #temp - #catch {interp alias "" ::>$OID ""} - - if {$force} { - #rename $cmd {} - - #removing the alias will remove the command - even if it's been renamed - interp alias {} $alias {} - - #if {[catch {rename $_cmd {} } why]} { - # #!todo - work out why some objects don't have matching command. - # #puts stderr "\t rename $_cmd {} failed" - #} else { - # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" - #} - - } - - set refns ::p::${OID}::_ref - #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" - #puts "- children: [llength [namespace children $refns]]" - #puts "- vars : [llength [info vars ${refns}::*]]" - #puts "- commands: [llength [info commands ${refns}::*]]" - #puts "- procs : [llength [info procs ${refns}::*]]" - #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" - #puts "- matching command: [llength [info commands ${refns}]]" - #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" - - - #foreach v [info vars ${refns}::*] { - # unset $v - #} - #foreach p [info procs ${refns}::*] { - # rename $p {} - #} - #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { - # interp alias {} $a {} - #} - - - #set ts1 [clock seconds] - #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." - #puts "- children: [llength [namespace children $refns]]" - #puts "- vars : [llength [info vars ${refns}::*]]" - - #puts "- commands: [llength [info commands ${refns}::*]]" - #puts "- procs : [llength [info procs ${refns}::*]]" - #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" - #puts "- exact command: [info commands ${refns}]" - - - - - #puts "--delete ::p::${OID}::_ref" - if {[namespace exists ::p::${OID}::_ref]} { - #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. - namespace delete ::p::${OID}::_ref:: - } - set ts2 [clock seconds] - #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" - - - #delete namespace where instance variables reside - #catch {namespace delete ::p::$OID} - namespace delete ::p::$OID - - #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout - return -} - - -interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility - - -dict set ::p::-1::_iface::o_methods Destructor {arglist {args}} -#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction? -#install a Destructor on the invocant's open level1 interface. -proc ::p::-1::Destructor {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - #lassign [lindex $map 0] OID alias itemCmd cmd - - set patterns [dict get $MAP interfaces level1] - - if {[llength $args] > 2} { - error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" - } - - set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - error "NOT TESTED" - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - - #::p::predator::remap $invocant - } - - - set ::p::${IID}::_iface::o_destructor_body [lindex $args end] - - if {[llength $args] > 1} { - #!todo - allow destructor args(?) - set arglist [lindex $args 0] - } else { - set arglist [list] - } - - set ::p::${IID}::_iface::o_destructor_args $arglist - - return -} - - - - - -interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit) - - -dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}} -proc ::p::-1::PatternMethod {_ID_ method arglist body} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. - set iface ::p::ifaces::>$iid_top - - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - set IID $iid_top - - - namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces - - - # examine the existing command-chain - set maxversion [::p::predator::method_chainhead $IID $method] - set headid [expr {$maxversion + 1}] - set THISNAME $method.$headid ;#first version will be $method.1 - - set next [::p::predator::next_script $IID $method $THISNAME $_ID_] - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - #puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls" - set body $varDecls\n[dict get $processed body] - #puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls" - } - - - set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist] - - #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] - #puts "\t\t--------------------" - #puts "\n" - #puts $body - #puts "\n" - #puts "\t\t--------------------" - proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body - - - - #pointer from method-name to head of the interface's command-chain - interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME - - - - if {$method in [dict keys $o_methods]} { - #error "patternmethod '$method' already present in interface $IID" - set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)" - if {[string match "*@next@*" $body]} { - append msg "\n EXTRA-WARNING: method contains @next@" - } - - puts stdout $msg - } else { - dict set o_methods $method [list arglist $arglist] - } - - #::p::-1::update_invocant_aliases $_ID_ - return -} - -#MultiMethod -#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants -# e.g1 $obj .. MultiMethod add {these 2} $arglist $body -# e.g2 $obj .. MultiMethod add {these n} $arglist $body -# -# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body -# -# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature. -# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature) -# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces) -# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? -# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed? -# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? -# (and how would we define the call order? - presumably as it appears in the conglomerate) -# (or could that be done with a more general method-wrapping mechanism?) -#...should multimethods use some sort of event mechanism, and/or message-passing system? -# -dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}} -proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { - set invocants [dict get $_ID_ i] - - error "not implemented" -} - -dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} -# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- ) -#we can create a method named "." by using the argprotect operator -- -# e.g >x .. Method -- . {args} $body -#It can then be called like so: >x . . -#This is not guaranteed to work and is not in the test suite -#for now we'll just use a highly unlikely string to indicate no argument was supplied -proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { - set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped - if {$methodname eq $non_argument_magicstring} { - return $default_method - } else { - set extracted_value [dict get $MAP invocantdata] - lset extracted_value 2 $methodname - dict set MAP invocantdata $extracted_value ;#write modified value back - #update the object's command alias to match - interp alias {} $alias {} ;#first we must delete it - interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] - - #! $object_command was initially created as the renamed alias - so we have to do it again - rename $alias $object_command - trace add command $object_command rename [list $object_command .. Rename] - return $methodname - } -} - -dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} -proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { - set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set extracted_patterndata [dict get $MAP patterndata] - set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] - if {$methodname eq $non_argument_magicstring} { - return $pattern_default_method - } else { - dict set extracted_patterndata patterndefaultmethod $methodname - dict set MAP patterndata $extracted_patterndata - return $methodname - } -} - - -dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}} -proc ::p::-1::Method {_ID_ method arglist bodydef args} { - set invocants [dict get $_ID_ i] - - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - set invocant_signature [list] ; - ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. - foreach role [lsort [dict keys $invocants]] { - lappend invocant_signature $role [llength [dict get $invocants $role]] - } - #note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this') - - - - lassign [dict get $MAP invocantdata] OID alias default_method object_command - set interfaces [dict get $MAP interfaces level0] - - - - ################################################################################# - if 0 { - set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface - set prev_open [set ::p::${iid_top}::_iface::o_open] - - set iface ::p::ifaces::>$iid_top - - set f_new 0 - if {![string length $iid_top]} { - set f_new 1 - } else { - if {[$iface . isClosed]} { - set f_new 1 - } - } - if {$f_new} { - #create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat $interfaces $iid_top] - dict set MAP interfaces $extracted_sub_dict - - } - set IID $iid_top - - } - ################################################################################# - - set IID [::p::predator::get_possibly_new_open_interface $OID] - - #upvar 0 ::p::${IID}:: IFACE - - namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces - - - #Interface proc - # examine the existing command-chain - set maxversion [::p::predator::method_chainhead $IID $method] - set headid [expr {$maxversion + 1}] - set THISNAME $method.$headid ;#first version will be $method.1 - - if {$method ni [dict keys $o_methods]} { - dict set o_methods $method [list arglist $arglist] - } - - #next_script will call to lower interface in iStack if we are $method.1 - set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_ - #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<" - - - #implement - #----------------------------------- - set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - set varDecls "" - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls\n[dict get $processed body] - } - - - set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist] - - - - - - - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - #if {[string length $varDecls]} { - # puts stdout "\t---------------------------------------------------------------" - # puts stdout "\t----- efficiency warning - implicit var declarations used -----" - # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" - # puts stdout "\t[string map [list \n \t\t\n] $body]" - # puts stdout "\t--------------------------" - #} - #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role - # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. - #(as specified by the @ operator during object conglomeration) - #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] - - #puts stdout "\t\t----------------------------" - #puts stdout "$body" - #puts stdout "\t\t----------------------------" - - proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body - - #----------------------------------- - - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME - - - #point to the interface command only. The dispatcher will supply the invocant data - #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method - set argvals "" - foreach argspec $arglist { - if {[llength $argspec] == 2} { - set a [lindex $argspec 0] - } else { - set a $argspec - } - if {$a eq "args"} { - append argvals " \{*\}\$args" - } else { - append argvals " \$$a" - } - } - set argvals [string trimleft $argvals] - #this proc directly on the object is not *just* a forwarding proc - # - it provides a context in which the 'uplevel 1' from the running interface proc runs - #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) - - #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain - - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { - ::p::${IID}::_iface::$method \$_ID_ $argvals - }] - - - if 0 { - if {[llength $argvals]} { - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { - apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ - }] - } else { - - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { - apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ - }] - - } - } - - - #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { - # ::p::${IID}::_iface::$method \$_ID_ $argvals - #}] - - #todo - for o_varspaces - #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method - #- this should work correctly with the 'uplevel 1' procs in the interfaces - - - if {[string length $o_varspace]} { - if {[string match "::*" $o_varspace]} { - namespace eval $o_varspace {} - } else { - namespace eval ::p::${OID}::$o_varspace {} - } - } - - - #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. - set colMethods ::p::${OID}::_meta::>colMethods - - if {[namespace which $colMethods] ne ""} { - if {![$colMethods . hasKey $method]} { - $colMethods . add [::p::internals::predator $_ID_ . $method .] $method - } - } - - #::p::-1::update_invocant_aliases $_ID_ - return - #::>pattern .. Create [::>pattern .. Namespace]::>method_??? - #return $method_object -} - - -dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}} -proc ::p::-1::V {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - - - set vlist [list] - foreach IID $ifaces { - dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { - if {[string match $glob $vname]} { - lappend vlist $vname - } - } - } - - - return $vlist -} - -#experiment from http://wiki.tcl.tk/4884 -proc p::predator::pipeline {args} { - set lambda {return -level 0} - foreach arg $args { - set lambda [list apply [dict get { - toupper {{lambda input} {string toupper [{*}$lambda $input]}} - tolower {{lambda input} {string tolower [{*}$lambda $input]}} - totitle {{lambda input} {string totitle [{*}$lambda $input]}} - prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}} - suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}} - } [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]] - } - return $lambda -} - -proc ::p::predator::get_apply_arg_0_oid {} { - set apply_args [lrange [info level 0] 2 end] - puts stderr ">>>>> apply_args:'$apply_args'<<<<" - set invocant [lindex $apply_args 0] - return [lindex [dict get $invocant i this] 0 0] -} -proc ::p::predator::get_oid {} { - #puts stderr "---->> [info level 1] <<-----" - set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 - tailcall lindex [dict get $_ID_ i this] 0 0 -} - -#todo - make sure this is called for all script installations - e.g propertyread etc etc -#Add tests to check code runs in correct namespace -#review - how does 'Varspace' command affect this? -proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} { - #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) - set arglist_apply "" - append arglist_apply "\$_ID_ " - foreach a $arglist { - if {$a eq "args"} { - append arglist_apply "{*}\$args" - } else { - append arglist_apply "\$[lindex $a 0] " - } - } - #!todo - allow fully qualified varspaces - if {[string length $varspace]} { - if {[string match ::* $varspace]} { - return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply" - } else { - #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n" - return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply" - } - } else { - #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" - #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" - - set script "tailcall apply \[list \{_ID_" - - if {[llength $arglist]} { - append script " $arglist" - } - append script "\} \{" - append script $body - append script "\} ::p::@OID@\] " - append script $arglist_apply - #puts stderr "\n88888888888888888888888888\n\t$script\n" - #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" - #return $script - - - #----------------------------------------------------------------------------- - # 2018 candidates - # - #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled - #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled - - - #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) - #faster though. - #return "uplevel 1 \{$body\}" - return "uplevel 1 [list $body]" - #----------------------------------------------------------------------------- - - - - - #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" - #return "uplevel 1 \{$script\}" - - #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail - #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail - - - - #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong - - #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns - - - #experiment with different dispatch mechanism (interp alias with 'namespace inscope') - #----------- - #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" - - - #return "uplevel 1 \{$body\}" ;#do nothing - - #---------- - - #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) - - #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body - - #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker - - #return "tailcall " - - - } -} - - -#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies. -#expand 'var' statements inline in method bodies -#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements. -# -#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces -#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches! -# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements. -#Think of var & varspace statments as a form of compile-time 'macro' -# -#caters for 2-element lists as arguments to var statement to allow 'aliasing' -#e.g var o_thing {o_data mydata} -# this will upvar o_thing as o_thing & o_data as mydata -# -proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { - set body {} - - #keep count of any explicit var statments per varspace in 'numDeclared' array - # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements. - - #default varspace is "" - #varspace should only have leading :: if it is an absolute namespace path. - - - foreach ln [split $rawbody \n] { - set trimline [string trim $ln] - - if {$trimline eq "var"} { - #plain var statement alone indicates we don't have any explicit declarations in this branch - # and we don't want implicit declarations for the current varspace either. - #!todo - implement test - - incr numDeclared($varspace) - - #may be further var statements e.g - in other code branches - #return [list body $rawbody varspaces_with_explicit_vars 1] - } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { - - #append body " upvar #0 " - #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " - #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " - - if {$varspace eq ""} { - append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " - } else { - if {[string match "::*" $varspace]} { - append body " namespace upvar $varspace " - } else { - append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " - } - } - - #any whitespace before or betw var names doesn't matter - about to use as list. - foreach varspec [string range $trimline 4 end] { - lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. - ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " - #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " - - append body "$var $alias " - - } - append body \n - - incr numDeclared($varspace) - } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { - #2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? - #it is assumed there is a single word following the 'varspace' keyword. - set varspace [string trim [string range $trimline 9 end]] - - if {$varspace in [list {{}} {""}]} { - set varspace "" - } - if {[string length $varspace]} { - #set varspace ::${varspace}:: - #no need to initialize numDeclared($varspace) incr will work anyway. - #if {![info exists numDeclared($varspace)]} { - # set numDeclared($varspace) 0 - #} - - if {[string match "::*" $varspace]} { - append body "namespace eval $varspace {} \n" - } else { - append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n" - } - - #puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} " - #append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n" - #append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n" - - #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n" - } - #!review - why? why do we need the magic 'default' name instead of just using the empty string? - #if varspace argument was empty string - leave it alone - } else { - append body $ln\n - } - } - - - - set varspaces [array names numDeclared] - return [list body $body varspaces_with_explicit_vars $varspaces] -} - - - - -#Interface Variables -dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} -proc ::p::-1::IV {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - - #!todo - test - #return [dict keys ::p::${OID}::_iface::o_variables $glob] - - set members [list] - foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { - if {[string match $glob $vname]} { - lappend members $vname - } - } - return $members -} - - -dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}} -proc ::p::-1::Methods {_ID_ {idx ""}} { - set invocants [dict get $_ID_ i] - set this_invocant [lindex [dict get $invocants this] 0] - lassign $this_invocant OID _etc - #set map [dict get $this_info map] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - set col ::p::${OID}::_meta::>colMethods - - if {[namespace which $col] eq ""} { - patternlib::>collection .. Create $col - foreach IID $ifaces { - foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { - if {![$col . hasIndex $m]} { - #todo - create some sort of lazy-evaluating method object? - #set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist] - $col . add [::p::internals::predator $_ID_ . $m .] $m - } - } - } - } - - if {[string length $idx]} { - return [$col . item $idx] - } else { - return $col - } -} - -dict set ::p::-1::_iface::o_methods M {arglist {}} -proc ::p::-1::M {_ID_} { - set invocants [dict get $_ID_ i] - set this_invocant [lindex [dict get $invocants this] 0] - lassign $this_invocant OID _etc - #set map [dict get $this_info map] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - set members [list] - foreach IID $ifaces { - foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { - lappend members $m - } - } - return $members -} - - -#review -#Interface Methods -dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}} -proc ::p::-1::IM {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - set this_invocant [lindex [dict get $invocants this] 0] - lassign $this_invocant OID _etc - #set map [dict get $this_info map] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] - -} - - - -dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}} -proc ::p::-1::InterfaceStacks {_ID_} { - upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP - return [dict get $MAP interfaces level0] -} - - -dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}} -proc ::p::-1::PatternStacks {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - return [dict get $MAP interfaces level1] -} - - -#!todo fix. need to account for references which were never set to a value -dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}} -proc ::p::-1::DeletePropertyReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - set cleared_references [list] - set refvars [info vars ::p::${OID}::_ref::*] - #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. - foreach rv $refvars { - foreach tinfo [trace info variable $rv] { - set ops {}; set cmd {} - lassign $tinfo ops cmd - trace remove variable $rv $ops $cmd - } - unset $rv - lappend cleared_references $rv - } - - - return [list deleted_property_references $cleared_references] -} - -dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}} -proc ::p::-1::DeleteMethodReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - set cleared_references [list] - - set iflist [dict get $MAP interfaces level0] - set iflist_reverse [lreferse $iflist] - #set iflist [dict get $MAP interfaces level0] - - - set refcommands [info commands ::p::${OID}::_ref::*] - foreach c $refcommands { - set reftail [namespace tail $c] - set field [lindex [split $c +] 0] - set field_is_a_method 0 - foreach IFID $iflist_reverse { - if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { - set field_is_a_method 1 - break - } - } - if {$field_is_a_method} { - #what if it's also a property? - interp alias {} $c {} - lappend cleared_references $c - } - } - - - return [list deleted_method_references $cleared_references] -} - - -dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}} -proc ::p::-1::DeleteReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_method this - - set result [dict create] - dict set result {*}[$this .. DeletePropertyReferences] - dict set result {*}[$this .. DeleteMethodReferences] - - return $result -} - -## -#Digest -# -#!todo - review -# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!) -# -#!todo - write tests - check that digest changes when properties of contained objects change value -# -#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method? -# -dict set ::p::-1::_iface::o_methods Digest {arglist {args}} -proc ::p::-1::Digest {_ID_ args} { - set invocants [dict get $_ID_ i] - # md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway. - #set this_invocant [lindex [dict get $invocants this] 0] - #lassign $this_invocant OID _etc - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] _OID alias default_method this - - - set interface_ids [dict get $MAP interfaces level0] - set IFID0 [lindex $interface_ids end] - - set known_flags {-recursive -algorithm -a -indent} - set defaults {-recursive 1 -algorithm md5 -indent ""} - if {[dict exists $args -a] && ![dict exists $args -algorithm]} { - dict set args -algorithm [dict get $args -a] - } - - set opts [dict merge $defaults $args] - foreach key [dict keys $opts] { - if {$key ni $known_flags} { - error "unknown option $key. Expected only: $known_flags" - } - } - - - set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256} - if {[dict get $opts -algorithm] ni $known_algos} { - error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos" - } - set algo [string tolower [dict get $opts -algorithm]] - - # append comma for each var so that all changes in adjacent vars detectable. - # i.e set x 34; set y 5 - # must be distinguishable from: - # set x 3; set y 45 - - if {[dict get $opts -indent] ne ""} { - set state "" - set indent "[dict get $opts -indent]" - } else { - set state "---\n" - set indent " " - } - append state "${indent}object_command: $this\n" - set indent "${indent} " - - #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state. - append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state. - - - - - #!todo - recurse into 'varspaces' - set varspaces_found [list] - append state "${indent}interfaces:\n" - foreach IID $interface_ids { - append state "${indent} - interface: $IID\n" - namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces - append state "${indent} varspaces:\n" - foreach vs $local_o_varspaces { - if {$vs ni $varspaces_found} { - lappend varspaces_found $vs - append state "${indent} - varspace: $vs\n" - } - } - } - - append state "${indent}vars:\n" - foreach var [info vars ::p::${OID}::*] { - append state "${indent} - [namespace tail $var] : \"" - if {[catch {append state "[set $var]"}]} { - append state "[array get $var]" - } - append state "\"\n" - } - - if {[dict get $opts -recursive]} { - append state "${indent}sub-objects:\n" - set subargs $args - dict set subargs -indent "$indent " - foreach obj [info commands ::p::${OID}::>*] { - append state "[$obj .. Digest {*}$subargs]\n" - } - - append state "${indent}sub-namespaces:\n" - set subargs $args - dict set subargs -indent "$indent " - foreach ns [namespace children ::p::${OID}] { - append state "${indent} - namespace: $ns\n" - foreach obj [info commands ${ns}::>*] { - append state "[$obj .. Digest {*}$subargs]\n" - } - } - } - - - if {$algo in {"" raw none}} { - return $state - } else { - if {$algo eq "md5"} { - package require md5 - return [::md5::md5 -hex $state] - } elseif {$algo eq "sha256"} { - package require sha256 - return [::sha2::sha256 -hex $state] - } elseif {$algo eq "blowfish"} { - package require patterncipher - patterncipher::>blowfish .. Create >b1 - set [>b1 . key .] 12341234 - >b1 . encrypt $state -final 1 - set result [>b1 . ciphertext] - >b1 .. Destroy - - } elseif {$algo eq "blowfish-binary"} { - - } else { - error "can't get here" - } - - } -} - - -dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}} -proc ::p::-1::Variable {_ID_ varname args} { - set invocants [dict get $_ID_ i] - - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - #this interface itself is always a co-invocant - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set interfaces [dict get $MAP interfaces level0] - - #set existing_IID [lindex $map 1 0 end] - set existing_IID [lindex $interfaces end] - - set prev_openstate [set ::p::${existing_IID}::_iface::o_open] - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #IID changed - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - - #update original object command - set ::p::${IID}::_iface::o_open 0 - } else { - set ::p::${IID}::_iface::o_open $prev_openstate - } - - set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface) - - if {[llength $args]} { - #!assume var not already present on interface - it is an error to define twice (?) - #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] - dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] - - - #Implement if there is a default - #!todo - correct behaviour when overlaying on existing object with existing var of this name? - #if {[string length $varspace]} { - # set ::p::${OID}::${varspace}::$varname [lindex $args 0] - #} else { - set ::p::${OID}::$varname [lindex $args 0] - #} - } else { - #lappend ::p::${IID}::_iface::o_variables [list $varname] - dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] - } - - #varspace '_iface' - - return -} - - -#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility - -dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}} -proc ::p::-1::PatternVariable {_ID_ varname args} { - set invocants [dict get $_ID_ i] - - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - ##this interface itself is always a co-invocant - #lassign [lindex $invocant 0 ] OID alias itemCmd cmd - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. - set iface ::p::ifaces::>$iid_top - - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] - } - set IID $iid_top - - set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. - - - if {[llength $args]} { - #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] - dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] - } else { - dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] - } - - return -} - -dict set ::p::-1::_iface::o_methods Varspaces {arglist args} -proc ::p::-1::Varspaces {_ID_ args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - if {![llength $args]} { - #query - set iid_top [lindex [dict get $MAP interfaces level0] end] - set iface ::p::ifaces::>$iid_top - if {![string length $iid_top]} { - error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " - } elseif {[$iface . isClosed]} { - error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " - } - return [set ::p::${iid_top}::_iface::o_varspaces] - } - set IID [::p::predator::get_possibly_new_open_interface $OID] - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces - - set varspaces $args - foreach vs $varspaces { - if {[string length $vs] && ($vs ni $o_varspaces)} { - if {[string match ::* $vs} { - namespace eval $vs {} - } else { - namespace eval ::p::${OID}::$vs {} - } - lappend o_varspaces $vs - } - } - return $o_varspaces -} - -#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface -dict set ::p::-1::_iface::o_methods Varspace {arglist args} -# set the default varspace for the interface, so that new methods/properties refer to it. -# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. -proc ::p::-1::Varspace {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - if {![llength $args]} { - #query - set iid_top [lindex [dict get $MAP interfaces level0] end] - set iface ::p::ifaces::>$iid_top - if {![string length $iid_top]} { - error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " - } elseif {[$iface . isClosed]} { - error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " - } - return [set ::p::${iid_top}::_iface::o_varspace] - } - set varspace [lindex $args 0] - - #set interfaces [dict get $MAP interfaces level0] - #set iid_top [lindex $interfaces end] - - set IID [::p::predator::get_possibly_new_open_interface $OID] - - - #namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces - - if {[string length $varspace]} { - #ensure namespace exists !? do after list test? - if {[string match ::* $varspace]} { - namespace eval $varspace {} - } else { - namespace eval ::p::${OID}::$varspace {} - } - if {$varspace ni $o_varspaces} { - lappend o_varspaces $varspace - } - } - set o_varspace $varspace -} - - -proc ::p::predator::get_possibly_new_open_interface {OID} { - #we need to re-upvar MAP rather than using a parameter - as we need to write back to it - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] - set iid_top [lindex $interfaces end] - - - set iface ::p::ifaces::>$iid_top - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - #puts stderr ">>>>creating new interface $iid_top" - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat $interfaces $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - - return $iid_top -} - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}} -# set the default varspace for the interface, so that new methods/properties refer to it. -# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. -proc ::p::-1::PatternVarspace {_ID_ varspace args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] - - set iface ::p::ifaces::>$iid_top - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - set IID $iid_top - - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces - if {[string length $varspace]} { - if {$varspace ni $o_varspaces} { - lappend o_varspaces $varspace - } - } - #o_varspace is the currently active varspace - set o_varspace $varspace - -} -################################################################################################################################################### - -#get varspace and default from highest interface - return all interface ids which define it -dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}} -proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] - - array set propinfo {} - set found_property_names [list] - #start at the lowest and work up (normal storage order of $interfaces) - foreach iid $interfaces { - set propinfodict [set ::p::${iid}::_iface::o_properties] - set matching_propnames [dict keys $propinfodict $propnamepattern] - foreach propname $matching_propnames { - if {$propname ni $found_property_names} { - lappend found_property_names $propname - } - lappend propinfo($propname,interfaces) $iid - ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one - if {[dict exists $propinfodict $propname default]} { - set propinfo($propname,default) [dict get $propinfodict $propname default] - } - set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] - } - } - - set resultdict [dict create] - foreach propname $found_property_names { - set fields [list varspace $propinfo($propname,varspace)] - if {[array exists propinfo($propname,default)]} { - lappend fields default [set propinfo($propname,default)] - } - lappend fields interfaces $propinfo($propname,interfaces) - dict set resultdict $propname $fields - } - return $resultdict -} - - -dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args} -proc ::p::-1::GetTopPattern {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set interfaces [dict get $MAP interfaces level1] - set iid_top [lindex $interfaces end] - if {![string length $iid_top]} { - lassign [dict get $MAP invocantdata] OID _alias _default_method object_command - error "No installed level1 interfaces (patterns) for object $object_command" - } - return ::p::ifaces::>$iid_top -} - - - -dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args} -proc ::p::-1::GetTopInterface {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set iid_top [lindex [dict get $MAP interfaces level0] end] - if {![string length $iid_top]} { - lassign [dict get $MAP invocantdata] OID _alias _default_method object_command - error "No installed level0 interfaces for object $object_command" - } - return ::p::ifaces::>$iid_top -} - - -dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} -proc ::p::-1::GetExpandableInterface {_ID_ args} { - -} - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods Property {arglist {property args}} -proc ::p::-1::Property {_ID_ property args} { - #puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args" - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - if {[llength $args] > 1} { - error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)" - } - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set interfaces [dict get $MAP interfaces level0] - set iid_top [lindex $interfaces end] - - set prev_openstate [set ::p::${iid_top}::_iface::o_open] - - set iface ::p::ifaces::>$iid_top - - - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat $interfaces $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - set IID $iid_top - - - namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace - - - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 - - - if {$headid == 1} { - #implementation - #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property - - #if {$o_varspace eq ""} { - # set ns ::p::${OID} - #} else { - # if {[string match "::*" $o_varspace]} { - # set ns $o_varspace - # } else { - # set ns ::p::${OID}::$o_varspace - # } - #} - #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]] - - proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]] - - - #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property - proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] - - - #chainhead pointers - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 - interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 - - - } - - if {($property ni [dict keys $o_methods])} { - interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property - } - - - - #installation on object - - #namespace eval ::p::${OID} [list namespace export $property] - - - - #obsolete? - #if {$property ni [P $_ID_]} { - #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces - #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant - #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant - #} - - #link main (GET)/(SET) to this interface - interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property - interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property - - #Only install property if no method of same name already installed here. - #(Method takes precedence over property because property always accessible via 'set' reference) - #convenience pointer to chainhead pointer. - if {$property ni [M $_ID_]} { - interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property - } else { - #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed - - - } - - - set varspace [set ::p::${IID}::_iface::o_varspace] - - - - #Install the matching Variable - #!todo - which should take preference if Variable also given a default? - #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { - # set o_variables [lreplace $o_variables $posn $posn o_$property] - #} else { - # lappend o_variables [list o_$property] - #} - dict set o_variables o_$property [list varspace $varspace] - - - - - if {[llength $args]} { - #should store default once only! - #set IFINFO(v,default,o_$property) $default - - set default [lindex $args end] - - dict set o_properties $property [list default $default varspace $varspace] - - #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { - # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] - #} else { - # lappend o_properties [list $property $default] - #} - - if {$varspace eq ""} { - set ns ::p::${OID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${OID}::$o_varspace - } - } - - set ${ns}::o_$property $default - #set ::p::${OID}::o_$property $default - } else { - - #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { - # set o_properties [lreplace $o_properties $posn $posn [list $property]] - #} else { - # lappend o_properties [list $property] - #} - dict set o_properties $property [list varspace $varspace] - - - #variable ::p::${OID}::o_$property - } - - - - - - #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. - #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) - #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} - - set colProperties ::p::${OID}::_meta::>colProperties - if {[namespace which $colProperties] ne ""} { - if {![$colProperties . hasKey $property]} { - $colProperties . add [::p::internals::predator $_ID_ . $property .] $property - } - } - - return -} -################################################################################################################################################### - - - -################################################################################################################################################### - -################################################################################################################################################### -interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility -dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}} -proc ::p::-1::PatternProperty {_ID_ property args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] - - set iface ::p::ifaces::>$iid_top - - if {(![string length $iid_top]) || ([$iface . isClosed])} { - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] - } - set IID $iid_top - - namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace - - - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 - - - - if {$headid == 1} { - #implementation - #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property - proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]] - #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property - proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] - - - #chainhead pointers - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 - interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 - - } - - if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} { - interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property - } - - set varspace [set ::p::${IID}::_iface::o_varspace] - - #Install the matching Variable - #!todo - which should take preference if Variable also given a default? - #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { - # set o_variables [lreplace $o_variables $posn $posn o_$property] - #} else { - # lappend o_variables [list o_$property] - #} - dict set o_variables o_$property [list varspace $varspace] - - set argc [llength $args] - - if {$argc} { - if {$argc == 1} { - set default [lindex $args 0] - dict set o_properties $property [list default $default varspace $varspace] - } else { - #if more than one arg - treat as a dict of options. - if {[dict exists $args -default]} { - set default [dict get $args -default] - dict set o_properties $property [list default $default varspace $varspace] - } else { - #no default value - dict set o_properties $property [list varspace $varspace] - } - } - #! only set default for property... not underlying variable. - #lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]] - } else { - dict set o_properties $property [list varspace $varspace] - } - return -} -################################################################################################################################################### - - - - - - - - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}} -proc ::p::-1::PatternPropertyRead {_ID_ property args} { - set invocants [dict get $_ID_ i] - - set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' - set OID [lindex $this_invocant 0] - #set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias defaut_command cmd - - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] - - set idxlist [::list] - if {[llength $args] == 1} { - set body [lindex $args 0] - } elseif {[llength $args] == 2} { - lassign $args idxlist body - } else { - error "wrong # args: should be \"property body\" or \"property idxlist body\"" - } - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] - if {$headid == 1} { - set headid 2 ;#reserve 1 for the getprop of the underlying property - } - - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 - set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ - - - #implement - #----------------------------------- - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - - #implementation - if {![llength $idxlist]} { - proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body - } else { - #what are we trying to achieve here? .. - proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body - } - - - #----------------------------------- - - - #adjust chain-head pointer to point to new head. - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid - - return -} -################################################################################################################################################### - - - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}} -proc ::p::-1::PropertyRead {_ID_ property args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead) - lassign [dict get $MAP invocantdata] OID alias default_command cmd - - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] - - - set idxlist [::list] - if {[llength $args] == 1} { - set body [lindex $args 0] - } elseif {[llength $args] == 2} { - lassign $args idxlist body - } else { - error "wrong # args: should be \"property body\" or \"property idxlist body\"" - } - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - - set ::p::${IID}::_iface::o_open 0 - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - - #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd] - - - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] - if {$headid == 1} { - set headid 2 - } - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself) - - set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] - - #implement - #----------------------------------- - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body - - #----------------------------------- - - - - #pointer from prop-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid - - - interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name. - if {$property ni [M $_ID_]} { - interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property - } -} -################################################################################################################################################### - - - - - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}} -proc ::p::-1::PropertyWrite {_ID_ property argname body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd - - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. - - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - set ::p::${IID}::_iface::o_open 0 - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - - #pw short for propertywrite - #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] - array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] - - - set maxversion [::p::predator::method_chainhead $IID (SET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (SET)$property.$headid - - set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] - - #implement - #----------------------------------- - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - - proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body - - #----------------------------------- - - - - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid -} -################################################################################################################################################### - - - - - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}} -proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd - - - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set existing_ifaces [lindex $map 1 1] - set posn [lsearch $existing_ifaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] - - #set ::p::${IID}::_iface::o_open 0 - } else { - } - - #pw short for propertywrite - array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] - - - - - return - -} -################################################################################################################################################### - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}} -proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd - - - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. - - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers - #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers - dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] - - set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (UNSET)$property.$headid - - set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - #note $arraykeypattern actually contains the name of the argument - if {[string trim $arraykeypattern] eq ""} { - set arraykeypattern _dontcare_ ;# - } - proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body - - #----------------------------------- - - - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid - -} -################################################################################################################################################### - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}} -proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #set ::p::${IID}::_iface::o_open 0 - } - - - upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers - dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] - - return -} -################################################################################################################################################### - - - -#lappend ::p::-1::_iface::o_methods Implements -#!todo - some way to force overriding of any abstract (empty) methods from the source object -#e.g leave interface open and raise an error when closing it if there are unoverridden methods? - - - - - -#implementation reuse - sugar for >object .. Clone >target -dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}} -proc ::p::-1::Extends {_ID_ pattern} { - if {!([string range [namespace tail $pattern] 0 0] eq ">")} { - error "'Extends' expected a pattern object" - } - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd object_command - - - tailcall $pattern .. Clone $object_command - -} -#implementation reuse - sugar for >pattern .. Create >target -dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}} -proc ::p::-1::PatternExtends {_ID_ pattern} { - if {!([string range [namespace tail $pattern] 0 0] eq ">")} { - error "'PatternExtends' expected a pattern object" - } - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd object_command - - - tailcall $pattern .. Create $object_command -} - - -dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}} -proc ::p::-1::Extend {_ID_ {idx ""}} { - puts stderr "Extend is DEPRECATED - use Expand instead" - tailcall ::p::-1::Expand $_ID_ $idx -} - -#set the topmost interface on the iStack to be 'open' -dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}} -proc ::p::-1::Expand {_ID_ {idx ""}} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set iid_top [lindex $interfaces end] - set iface ::p::ifaces::>$iid_top - - if {![string length $iid_top]} { - #no existing interface - create a new one - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [list $iid_top] - dict set MAP interfaces $extracted_sub_dict ;#write new interface into map - $iface . open - return $iid_top - } else { - if {[$iface . isOpen]} { - #already open.. - #assume ready to expand.. shared or not! - return $iid_top - } - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - if {[$iface . refCount] > 1} { - if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} { - #!warning! not exercised by test suites! - - #remove ourself from the usedby list of the previous interface - array unset ::p::${iid_top}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - #remove existing interface & add - set posn [lsearch $interfaces $iid_top] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - - set iid_top $IID - set iface ::p::ifaces::>$iid_top - } - } - } - - $iface . open - return $iid_top -} - -dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}} -proc ::p::-1::PatternExtend {_ID_ {idx ""}} { - puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead" - tailcall ::p::-1::PatternExpand $_ID_ $idx -} - - - -#set the topmost interface on the pStack to be 'open' if it's not shared -# if shared - 'copylink' to new interface before opening for extension -dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}} -proc ::p::-1::PatternExpand {_ID_ {idx ""}} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - #puts stderr "no tests written for PatternExpand " - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces - set iid_top [lindex $ifaces end] - set iface ::p::ifaces::>$iid_top - - if {![string length $iid_top]} { - #no existing interface - create a new one - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [list $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [list $iid_top] - $iface . open - return $iid_top - } else { - if {[$iface . isOpen]} { - #already open.. - #assume ready to expand.. shared or not! - return $iid_top - } - - if {[$iface . refCount] > 1} { - if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} { - #!WARNING! not exercised by test suite! - #remove ourself from the usedby list of the previous interface - array unset ::p::${iid_top}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $ifaces $iid_top] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID] - - set iid_top $IID - set iface ::p::ifaces::>$iid_top - } - } - } - - $iface . open - return $iid_top -} - - - - - -dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}} -proc ::p::-1::Properties {_ID_ {idx ""}} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - set col ::p::${OID}::_meta::>colProperties - - if {[namespace which $col] eq ""} { - patternlib::>collection .. Create $col - foreach IID $ifaces { - dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] { - if {![$col . hasIndex $prop]} { - $col . add [::p::internals::predator $_ID_ . $prop .] $prop - } - } - } - } - - if {[string length $idx]} { - return [$col . item $idx] - } else { - return $col - } -} - -dict set ::p::-1::_iface::o_methods P {arglist {}} -proc ::p::-1::P {_ID_} { - set invocants [dict get $_ID_ i] - set this_invocant [lindex [dict get $invocants this] 0] - lassign $this_invocant OID _etc - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - set members [list] - foreach IID $interfaces { - foreach prop [dict keys [set ::p::${IID}::_iface::o_properties]] { - lappend members $prop - } - } - return [lsort $members] - -} -#Interface Properties -dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}} -proc ::p::-1::IP {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set members [list] - - foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { - if {[string match $glob [lindex $m 0]]} { - lappend members [lindex $m 0] - } - } - return $members -} - - -#used by rename.test - theoretically should be on a separate interface! -dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}} -proc ::p::-1::CheckInvocants {_ID_ args} { - #check all invocants in the _ID_ are consistent with data stored in their MAP variable - set status "ok" ;#default to optimistic assumption - set problems [list] - - set invocant_dict [dict get $_ID_ i] - set invocant_roles [dict keys $invocant_dict] - - foreach role $invocant_roles { - set invocant_list [dict get $invocant_dict $role] - foreach aliased_invocantdata $invocant_list { - set OID [lindex $aliased_invocantdata 0] - set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] - #we use lrange to make sure the lists are in canonical form - if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { - set status "not-ok" - lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] - } - } - - } - - - set result [dict create] - dict set result status $status - dict set result problems $problems - - return $result -} - - -#get or set t -dict set ::p::-1::_iface::o_methods Namespace {arglist {args}} -proc ::p::-1::Namespace {_ID_ args} { - #set invocants [dict get $_ID_ i] - #set this_invocant [lindex [dict get $invocants this] 0] - #lassign $this_invocant OID this_info - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set IID [lindex [dict get $MAP interfaces level0] end] - - namespace upvar ::p::${IID}::_iface o_varspace active_varspace - - if {[string length $active_varspace]} { - set ns ::p::${OID}::$active_varspace - } else { - set ns ::p::${OID} - } - - #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object? - # - should .. Namespace be usable at all from outside the object? - - - if {[llength $args]} { - #special case some of the namespace subcommands. - - #delete - if {[string match "d*" [lindex $args 0]]} { - error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object." - } - #upvar,ensemble,which,code,origin,expor,import,forget - if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} { - return [namespace eval $ns [list namespace {*}$args]] - } - #current - if {[string match "cu*" [lindex $args 0]]} { - return $ns - } - - #children,eval,exists,inscope,parent,qualifiers,tail - return [namespace {*}[linsert $args 1 $ns]] - } else { - return $ns - } -} - - - - - - - - - - -dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}} -proc ::p::-1::PatternUnknown {_ID_ args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - #::p::predator::remap $invocant - } - - set handlermethod [lindex $args 0] - - - if {[llength $args]} { - set ::p::${IID}::_iface::o_unknown $handlermethod - return - } else { - set ::p::${IID}::_iface::o_unknown $handlermethod - } - -} - - - -dict set ::p::-1::_iface::o_methods Unknown {arglist {args}} -proc ::p::-1::Unknown {_ID_ args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. - - set prev_open [set ::p::${existing_IID}::_iface::o_open] - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - set ::p::${IID}::_iface::o_open 0 - } else { - set ::p::${IID}::_iface::o_open $prev_open - } - - set handlermethod [lindex $args 0] - - if {[llength $args]} { - set ::p::${IID}::_iface::o_unknown $handlermethod - #set ::p::${IID}::(unknown) $handlermethod - - - #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod - interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod - interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod - - #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod] - #namespace eval ::p::${OID} [list namespace unknown $handlermethod] - - return - } else { - set ::p::${IID}::_iface::o_unknown $handlermethod - } - -} - - -#useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []' -# should also work for non-object results -dict set ::p::-1::_iface::o_methods As {arglist {varname}} -proc ::p::-1::As {_ID_ varname} { - set invocants [dict get $_ID_ i] - #puts stdout "invocants: $invocants" - #!todo - handle multiple invocants with other roles, not just 'this' - - set OID [lindex [dict get $_ID_ i this] 0 0] - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - tailcall set $varname $cmd - } else { - #puts stdout "info level 1 [info level 1]" - set role_members [dict get $_ID_ i this] - if {[llength $role_members] == 1} { - set member [lindex $role_members 0] - lassign $member _OID namespace default_method stackvalue _wrapped - tailcall set $varname $stackvalue - } else { - #multiple invocants - return all results as a list - set resultlist [list] - foreach member $role_members { - lassign $member _OID namespace default_method stackvalue _wrapped - lappend resultlist $stackvalue - } - tailcall set $varname $resultlist - } - } -} - -#!todo - AsFileStream ?? -dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}} -proc ::p::-1::AsFile {_ID_ filename args} { - dict set default -force 0 - dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object - set opts [dict merge $default $args] - set force [dict get $opts -force] - set dumpmethod [dict get $opts -dumpmethod] - - - if {[file pathtype $filename] eq "relative"} { - set filename [pwd]/$filename - } - set filedir [file dirname $filename] - if {![sf::file_writable $filedir]} { - error "(method AsFile) ERROR folder $filedir is not writable" - } - if {[file exists $filename]} { - if {!$force} { - error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite" - } - if {![sf::file_writable $filename]} { - error "(method AsFile) ERROR file $filename is not writable - check permissions" - } - } - set fd [open $filename w] - fconfigure $fd -translation binary - - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $_ID_ i this] 0 0] - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - #tailcall set $varname $cmd - set object_data [$cmd {*}$dumpmethod] - puts -nonewline $fd $object_data - close $fd - return [list status 1 bytes [string length $object_data] filename $filename] - } else { - #puts stdout "info level 1 [info level 1]" - set role_members [dict get $_ID_ i this] - if {[llength $role_members] == 1} { - set member [lindex $role_members 0] - lassign $member _OID namespace default_method stackvalue _wrapped - puts -nonewline $fd $stackvalue - close $fd - #tailcall set $varname $stackvalue - return [list status 1 bytes [string length $stackvalue] filename $filename] - } else { - #multiple invocants - return all results as a list - set resultlist [list] - foreach member $role_members { - lassign $member _OID namespace default_method stackvalue _wrapped - lappend resultlist $stackvalue - } - puts -nonewline $fd $resultset - close $fd - return [list status 1 bytes [string length $resultset] filename $filename] - #tailcall set $varname $resultlist - } - } - -} - - - -dict set ::p::-1::_iface::o_methods Object {arglist {}} -proc ::p::-1::Object {_ID_} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - set result [string map [list ::> ::] $cmd] - if {![catch {info level -1} prev_level]} { - set called_by "(called by: $prev_level)" - } else { - set called_by "(called by: interp?)" - - } - - puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" - puts stdout " (returning $result)" - - return $result -} - -#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname -dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} -proc ::p::-1::MakeAlias {_ID_cmdname } { - set OID [::p::obj_get_this_oid $_ID_] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - error "concept probably won't work - try making dispatcher understand trailing '= cmdname' " -} -dict set ::p::-1::_iface::o_methods ID {arglist {}} -proc ::p::-1::ID {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - return $OID -} - -dict set ::p::-1::_iface::o_methods IFINFO {arglist {}} -proc ::p::-1::IFINFO {_ID_} { - puts stderr "--_ID_: $_ID_--" - set OID [::p::obj_get_this_oid $_ID_] - upvar #0 ::p::${OID}::_meta::map MAP - - puts stderr "-- MAP: $MAP--" - - set interfaces [dict get $MAP interfaces level0] - set IFID [lindex $interfaces 0] - - if {![llength $interfaces]} { - puts stderr "No interfaces present at level 0" - } else { - foreach IFID $interfaces { - set iface ::p::ifaces::>$IFID - puts stderr "$iface : [$iface --]" - puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" - set variables [set ::p::${IFID}::_iface::o_variables] - puts stderr "\tvariables: $variables" - } - } - -} - - - - -dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} -proc ::p::-1::INVOCANTDATA {_ID_} { - #same as a call to: >object .. - return $_ID_ -} - -#obsolete? -dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}} -proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} { - set updated_ID_ $_ID_ - array set updated_roles [list] - - set invocants [dict get $_ID_ i] - set invocant_roles [dict keys $invocants] - foreach role $invocant_roles { - - set role_members [dict get $invocants $role] - foreach member [dict get $invocants $role] { - #each member is a 2-element list consisting of the OID and a dictionary - #each member is a 5-element list - #set OID [lindex $member 0] - #set object_dict [lindex $member 1] - lassign $member OID alias itemcmd cmd wrapped - - set MAP [set ::p::${OID}::_meta::map] - #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} - - if {[dict get $MAP invocantdata] eq $member} - #same - nothing to do - - } else { - package require overtype - puts stderr "---------------------------------------------------------" - puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" - set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] - puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" - puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" - puts stderr "---------------------------------------------------------" - #take _meta::map version - lappend updated_roles($role) [dict get $MAP invocantdata] - } - - } - - #overwrite changed roles only - foreach role [array names updated_roles] { - dict set updated_ID_ i $role [set updated_roles($role)] - } - - return $updated_ID_ -} - - - -dict set ::p::-1::_iface::o_methods INFO {arglist {}} -proc ::p::-1::INFO {_ID_} { - set result "" - append result "_ID_: $_ID_\n" - - set invocants [dict get $_ID_ i] - set invocant_roles [dict keys $invocants] - append result "invocant roles: $invocant_roles\n" - set total_invocants 0 - foreach key $invocant_roles { - incr total_invocants [llength [dict get $invocants $key]] - } - - append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" - foreach key $invocant_roles { - append result "\t-------------------------------\n" - append result "\trole: $key\n" - set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants - append result "\t Raw data for this role: $role_members\n" - append result "\t Number of invocants in this role: [llength $role_members]\n" - foreach member $role_members { - #set OID [lindex [dict get $invocants $key] 0 0] - set OID [lindex $member 0] - append result "\t\tOID: $OID\n" - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - append result "\t\tmap:\n" - foreach key [dict keys $MAP] { - append result "\t\t\t$key\n" - append result "\t\t\t\t [dict get $MAP $key]\n" - append result "\t\t\t----\n" - } - lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped - append result "\t\tNamespace: $namespace\n" - append result "\t\tDefault method: $default_method\n" - append result "\t\tCommand: $cmd\n" - append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n" - append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n" - append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n" - } else { - lassign $member _OID namespace default_method stackvalue _wrapped - append result "\t\t last item on the predator stack is a value not an object" - append result "\t\t Value is: $stackvalue" - - } - } - append result "\n" - append result "\t-------------------------------\n" - } - - - - return $result -} - - - - -dict set ::p::-1::_iface::o_methods Rename {arglist {args}} -proc ::p::-1::Rename {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - if {![llength $args]} { - error "Rename expected \$newname argument" - } - - #Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant? - upvar #0 ::p::${OID}::_meta::map MAP - - - - #puts ">>.>> Rename. _ID_: $_ID_" - - if {[catch { - - if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { - - #appears to be a 'trace command rename' firing - #puts "\t>>>> rename trace fired $MAP $args <<<" - - lassign $args oldcmd newcmd - set extracted_invocantdata [dict get $MAP invocantdata] - lset extracted_invocantdata 3 $newcmd - dict set MAP invocantdata $extracted_invocantdata - - - lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped - - #Write the same info into the _ID_ value of the alias - interp alias {} $alias {} ;#first we must delete it - interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] - - - - #! $object_command was initially created as the renamed alias - so we have to do it again - uplevel 1 [list rename $alias $object_command] - trace add command $object_command rename [list $object_command .. Rename] - - } elseif {[llength $args] == 1} { - #let the rename trace fire and we will be called again to do the remap! - uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] - } else { - error "Rename expected \$newname argument ." - } - - } errM]} { - puts stderr "\t@@@@@@ rename error" - set ruler "\t[string repeat - 80]" - puts stderr $ruler - puts stderr $errM - puts stderr $ruler - - } - - return - - -} - -proc ::p::obj_get_invocants {_ID_} { - return [dict get $_ID_ i] -} -#The invocant role 'this' is special and should always have only one member. -# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX -proc ::p::obj_get_this_oid {_ID_} { - return [lindex [dict get $_ID_ i this] 0 0] -} -proc ::p::obj_get_this_ns {_ID_} { - return [lindex [dict get $_ID_ i this] 0 1] -} - -proc ::p::obj_get_this_cmd {_ID_} { - return [lindex [dict get $_ID_ i this] 0 3] -} -proc ::p::obj_get_this_data {_ID_} { - lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd - #set this_invocant_data {*}[dict get $_ID_ i this] - return [list oid $OID ns $ns cmd $cmd] -} -proc ::p::map {OID varname} { - tailcall upvar #0 ::p::${OID}::_meta::map $varname -} - - - +package require dictutils +package provide metaface [namespace eval metaface { + variable version + set version 1.2.5 +}] + + + + +#example datastructure: +#$_ID_ +#{ +#i +# { +# this +# { +# {16 ::p::16 item ::>x {}} +# } +# role2 +# { +# {17 ::p::17 item ::>y {}} +# {18 ::p::18 item ::>z {}} +# } +# } +#context {} +#} + +#$MAP +#invocantdata {16 ::p::16 item ::>x {}} +#interfaces {level0 +# { +# api0 {stack {123 999}} +# api1 {stack {333}} +# } +# level0_default api0 +# level1 +# { +# } +# level1_default {} +# } +#patterndata {patterndefaultmethod {}} + + +namespace eval ::p::predator {} +#temporary alternative to ::p::internals namespace. +# - place predator functions here until ready to replace internals. + + +namespace eval ::p::snap { + variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks. +} + + + + +# not called directly. Retrieved using 'info body ::p::predator::getprop_template' +#review - why use a proc instead of storing it as a string? +proc ::p::predator::getprop_template {_ID_ args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args]} { + #lassign [lindex $invocant 0] OID alias itemCmd cmd + if {[array exists ${ns}::o_%prop%]} { + #return [set ${ns}::o_%prop%($args)] + if {[llength $args] == 1} { + return [set ::p::${OID}::o_%prop%([lindex $args 0])] + } else { + return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]] + } + } else { + set val [set ${ns}::o_%prop%] + + set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] + if {$rType eq "object"} { + #return [$val . item {*}$args] + return [$val {*}$args] + } else { + #treat as list? + return [lindex $val $args] + } + } + } else { + return [set ${ns}::o_%prop%] + } +} + + +proc ::p::predator::getprop_template_immediate {_ID_ args} { + if {[llength $args]} { + if {[array exists %ns%::o_%prop%]} { + return [set %ns%::o_%prop%($args)] + } else { + set val [set %ns%::o_%prop%] + set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] + if {$rType eq "object"} { + #return [$val . item {*}$args] + #don't assume defaultmethod named 'item'! + return [$val {*}$args] + } else { + #treat as list? + return [lindex $val $args] + } + } + } else { + return [set %ns%::o_%prop%] + } +} + + + + + + + + +proc ::p::predator::getprop_array {_ID_ prop args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + + #upvar 0 ::p::${OID}::o_${prop} prop + #1st try: assume array + if {[catch {array get ::p::${OID}::o_${prop}} result]} { + #treat as list (why?) + #!review + if {[info exists ::p::${OID}::o_${prop}]} { + array set temp [::list] + set i 0 + foreach element ::p::${OID}::o_${prop} { + set temp($i) $element + incr i + } + set result [array get temp] + } else { + error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" + } + } + return $result +} + +proc ::p::predator::setprop_template {prop _ID_ args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args] == 1} { + #return [set ::p::${OID}::o_%prop% [lindex $args 0]] + return [set ${ns}::o_%prop% [lindex $args 0]] + + } else { + if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { + #treat attempt to perform indexed write to nonexistant var, same as indexed write to array + + #2 args - single index followed by a value + if {[llength $args] == 2} { + return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] + } else { + #multiple indices + #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] + return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] + } + } else { + #treat as list + return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] + } + } +} + +#-------------------------------------- +#property read & write traces +#-------------------------------------- + + +proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} { + + #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' " + + #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain. + + if {[llength $idx]} { + if {[llength $idx] == 1} { + set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx] + } else { + lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx] + } + return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value + } else { + if {![info exists $refname]} { + set $refname [$get_cmd $_ID_ {*}$indices] + } else { + set newval [$get_cmd $_ID_ {*}$indices] + if {[set $refname] ne $newval} { + set $refname $newval + } + } + return + } +} + + + + +proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} { + #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" + + + #derive the name of the write command from the ref var. + set indices [lassign [split [namespace tail $refname] +] prop] + + + #assert - we will never have both a list in indices and an idx value + if {[llength $indices] && ($idx ne "")} { + #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x + #review - are there any datastructures which would/should allow this? + #this assertion is really just here as a sanity check for now + error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" + } + + #upvar #0 ::p::${OID}::_meta::map MAP + #puts "-->propref_trace_write map: $MAP" + + #temporarily deactivate refsync trace + #puts stderr -->1>--removing_trace_o_${field} +### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + #we need to catch, and re-raise any error that we may receive when writing the property + # because we have to reinstate the propvar_write_TraceHandler after the call. + #(e.g there may be a propertywrite handler that deliberately raises an error) + + set excludesync_refs $refname + set cmd ::p::${OID}::(SET)$prop + + + set f_error 0 + if {[catch { + + if {![llength $indices]} { + if {[string length $idx]} { + $cmd $_ID_ $idx [set ${refname}($idx)] + #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] + + } else { + $cmd $_ID_ [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] + } + } else { + #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" + $cmd $_ID_ {*}$indices [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices + } + + } result]} { + set f_error 1 + } + + + + + #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write + #reactivate refsync trace + #puts stderr "****** reactivating refsync trace on o_$field" + #puts stderr -->2>--reactivating_trace_o_${field} + ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + + if {$f_error} { + #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. + # ? return -code error $errMsg ? -errorinfo + + #!quick n dirty + #error $errorMsg + return -code error -errorinfo $::errorInfo $result + } else { + return $result + } +} + + + + + +proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { + #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'" + #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array') + + set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set + + #set updated_value [::p::predator::getprop_array $prop $_ID_] + #puts stderr "-->array_Trace updated_value:$updated_value" + if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} { + puts stderr "-->propref_trace_array error $errm" + array set $refname {} + } + + #return value ignored for +} + + +#-------------------------------------- +# +proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + + + #don't rely on variable name passed by trace - may have been 'upvar'ed + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar" + + set iflist [dict get $MAP interfaces level0] + + set plist [list] + + #!todo - get propertylist from cache on object(?) + foreach IFID [lreverse $iflist] { + dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { + #lassign $pdef v + if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} { + if {[array exists ::p::${OID}::o_${prop}]} { + lappend plist $prop [array get ::p::${OID}::o_${prop}] + } else { + #ignore - array only represents properties that have been set. + #error "property $v is not set" + #!todo - unset corresponding items in $refvar if needed? + } + } + } + } + array set $refvar $plist +} + + +proc ::p::predator::object_read_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" + + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + if {[string length $IID]} { + #property + if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { + puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" + } + } else { + #method + error "property '$idx' not found" + } +} + + +proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd + + #!todo - ??? + + if {![llength [info commands ::p::${OID}::$idx]]} { + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set found 0 + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set found 1 + break + } + } + + if {$found} { + unset ::p::${OID}::o_$idx + } else { + puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" + } + } +} + + +proc ::p::predator::object_write_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" + + + if {![llength [info commands ::p::${OID}::$idx]]} { + #!todo - create new property in interface upon attempt to write to non-existant? + # - or should we require some different kind of object-reference for that? + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + #$IID is now topmost interface in default iStack which has this property + + if {[string length $IID]} { + #write to defined property + + ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] + } else { + #!todo - allow write of method body back to underlying object? + #attempted write to 'method' ..undo(?) + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "cannot write to method '$idx'" + #for now - disallow + } + } + +} + + + +proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} { + #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + + set refindices [lassign [split [namespace tail $refname] +] prop] + #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop + #if there is no PropertyUnset command - we unset the underlying variable directly + + trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + + if {[catch { + + #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value + #i.e + if {[llength $refindices] && [string length $idx]} { + puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" + error "unexpected call to propref_trace_unset" + } + + + upvar #0 ::p::${OID}::_meta::map MAP + + set iflist [dict get $MAP interfaces level0] + #find topmost interface containing this $prop + set IID "" + foreach id [lreverse $iflist] { + if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + if {![string length $IID]} { + error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" + } + + + + + + + if {[string length $idx]} { + #eval "$_alias ${unset_}$field $idx" + #what happens to $refindices??? + + + #!todo varspace + + if {![llength $refindices]} { + #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop}($idx) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx + } + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx + } else { + #assert - won't get here + error 1a + + } + + } else { + if {[llength $refindices]} { + #error 2a + #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + #review - what about list-type property? + #if {[array exists ::p::${OID}::o_${prop}]} ??? + unset ::p::${OID}::o_${prop}($refindices) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices + } + + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices + + + } else { + #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + #ref is not of form prop+x etc and no idx in the trace - this is a plain unset + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop} + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" + } + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} + + } + } + + + + + } errM]} { + #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" + set ruler [string repeat - 80] + puts stderr "\t$ruler" + puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + puts stderr "\t$ruler" + puts stderr $errM + puts stderr "\t$ruler" + + } else { + #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + #puts stderr "*@*@*@*@ end propref_trace_unset - no error" + } + + trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + +} + + + + +proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} { + + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + + + if {[string length $triggeringRef]} { + set idx [lsearch -exact $refvars $triggeringRef] + if {$idx >= 0} { + set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] + } + } + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" + return + } + + + #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset + # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" + if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { + #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" + puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" + } + + + puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " + + + + upvar $vtraced SYNCVARIABLE + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + + + if {[array exists SYNCVARIABLE]} { + + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + + #set triggeringRefIdx $vidx + + if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { + set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] + } else { + set triggering_indices [list] + } + + + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + + + + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #check indices of triggering refvar match this refvars indices + + + if {$reftail eq [namespace tail $triggeringRef]} { + #!todo - add test + error "untested, possibly unused branch spuds2" + #puts "222222222222222222" + unset $refvar + } else { + + #error "untested - branch spuds2a" + + + } + + } else { + #!todo -add test + #reference is directly to property var + error "untested, possibly unused branch spuds3" + #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? + puts "\t33333333333333333333" + + if {[string length $triggeringRefIdx]} { + unset $refvar($triggeringRefIdx) + } + } + } + + } + + + + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + + + + +} + + +proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} { + + upvar $vtraced SYNCVARIABLE + + set refvars [::list] + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + + + #short_circuit breaks unset traces for array elements (why?) + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + return + } else { + puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + } + + if {[catch { + + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + + + if {[array exists SYNCVARIABLE]} { + + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + set triggeringRefIdx $vidx + + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + + + + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + unset $refvar + + } + + } + + + + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + } errM]} { + set ruler [string repeat * 80] + puts stderr "\t$ruler" + puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" + puts stderr "\t$ruler" + puts stderr $::errorInfo + puts stderr "\t$ruler" + + } + +} + +proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} { + error hmmmmm + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " + set refvars [::list] + + #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + #assert triggeringRef is in the list + if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { + error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" + } + set refposn [lsearch -exact $refvars $triggeringRef] + #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 + set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" + return [list refs_updates [list]] + } + + #suppress the propref_trace_* traces on all refvars + array set traces [::list] + array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." + #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync + #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? + #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #all other traces are 'external' + lappend external_traces($rv) $tinfo + #trace remove variable $rv $ops $cmd + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + if {![info exists SYNCVARIABLE]} { + error "WARNING: REVIEW why does $vartraced not exist here?" + } + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set treat_vtraced_as_array 1 + } else { + set treat_vtraced_as_array 0 + } + + set refs_updated [list] + set refs_deleted [list] ;#unset due to index no longer being relevant + if {$treat_vtraced_as_array} { + foreach refvar $refvars { + #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + if {[llength $indices]} { + if {[llength $indices] == 1} { + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + #error "untested xxx-a" + set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] + lappend refs_updated $refvar + } else { + #test exists + #error "xxx-ok single index" + #updating a different part of the property - nothing to do + } + } else { + #nested index + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + if {[llength $ref_indices] == 1} { + #error "untested xxx-b1" + set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] + } else { + #assert llength $ref_indices > 1 + #NOTE - we cannot test index equivalence reliably/simply just by comparing indices + #compare by value + + if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { + #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" + if {[set $refvar] ne $possiblyNewVal} { + set $refvar $possiblyNewVal + } + } else { + #fail to retrieve underlying value corrsponding to these $indices + unset $refvar + } + } + } else { + #test exists + #error "untested xxx-ok deepindex" + #updating a different part of the property - nothing to do + } + } + } else { + error "untested xxx-c" + + } + + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + if {[llength $indices] == 1} { + set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] + } else { + lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] + } + lappend refs_updated $refvar + } else { + error "untested yyy" + set $refvar $SYNCVARIABLE + } + } + } + } else { + #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) + # + foreach refvar $refvars { + #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + + if {[llength $indices]} { + #see if this update would affect this curried ref + #1st see if we can short-circuit our comparison based on numeric-indices + if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { + #both sets of indices are purely numeric (no end end-1 etc) + set rlen [llength $ref_indices] + set ilen [llength $indices] + set minlen [expr {min($rlen,$ilen)}] + set matched_firstfew_indices 1 ;#assume the best + for {set i 0} {$i < $minlen} {incr i} { + if {[lindex $ref_indices $i] ne [lindex $indices $i]} { + break ;# + } + } + if {!$matched_firstfew_indices} { + #update of this refvar not required + #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" + break ;#break to next refvar in the foreach loop + } + } + #failed to short-circuit + + #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set $refvar] ne $newval} { + set $refvar $newval + lappend refs_updated $refvar + } + + } else { + #we must be updating the entire variable - so this curried ref will either need to be updated or unset + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set ${refvar}] ne $newval} { + set ${refvar} $newval + lappend refs_updated $refvar + } + } + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + #error "untested zzz-a" + set newval [lindex $SYNCVARIABLE $indices] + if {[lindex [set $refvar] $indices] ne $newval} { + lset ${refvar} $indices $newval + lappend refs_updated $refvar + } + } else { + if {[set ${refvar}] ne $SYNCVARIABLE} { + set ${refvar} $SYNCVARIABLE + lappend refs_updated $refvar + } + } + + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + + #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + } + foreach rv [array names external_traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + #trace add variable $rv $ops $cmd + } + } + } + + + return [list updated_refs $refs_updated] +} + +#purpose: update all relevant references when context variable changed directly +proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { + #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. + #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler + + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" + set t_info [trace vinfo $vtraced] + foreach t_spec $t_info { + set t_ops [lindex $t_spec 0] + if {$op in $t_ops} { + puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" + } + } + + #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- + #vtype = array | array-item | list | simple + + set refvars [::list] + + ############################ + #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! + #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) + #The alternative 'info vars' does not trigger traces + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + ############################ + + #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" + return + } + + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars + array set predator_traces [::list] + #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. + #ie for something like 'trace add variable someref {write read array} somefunc' + # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace + array set external_read_traces [::list] ;#pure read traces the library user may have added + array set external_readetc_traces [::list] ;#read + something else traces the library user may have added + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + #if {$ops in {read write unset array}} {} + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend predator_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #other traces + # puts "##trace $tinfo" + if {"read" in $ops} { + if {[llength $ops] == 1} { + #pure read - + lappend external_read_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + } else { + #mixed operation trace - remove and reinstall without the 'read' + lappend external_readetc_traces($rv) $tinfo + set other_ops [lsearch -all -inline -not $ops "read"] + trace remove variable $rv $ops $cmd + #reinstall trace for non-read operations only + trace add variable $rv $other_ops $cmd + } + } + } + } + } + + + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set vtracedIsArray 1 + } else { + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" + #puts "**write*********** refvars: $refvars" + + #!todo? unroll foreach into multiple foreaches within ifs? + #foreach refvar $refvars {} + + + #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" + if {[string length $vidx]} { + #indexable + if {$vtracedIsArray} { + + foreach refvar $refvars { + #puts stderr " - - a refvar $refvar vidx: $vidx" + set tail [namespace tail $refvar] + if {[string match "${prop}+*" $tail]} { + #refvar is curried + #only set if vidx matches curried index + #!todo -review + set idx [lrange [split $tail +] 1 end] + if {$idx eq $vidx} { + set newval [set SYNCVARIABLE($vidx)] + if {[set $refvar] ne $newval} { + set ${refvar} $newval + } + #puts stderr "=a.1=> updated $refvar" + } + } else { + #refvar is simple + set newval [set SYNCVARIABLE($vidx)] + if {![info exists ${refvar}($vidx)]} { + #new key for this array + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } else { + set oldval [set ${refvar}($vidx)] + if {$oldval ne $newval} { + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } + } + #puts stderr "=a.2=> updated ${refvar} $vidx" + } + } + + + + } else { + + + foreach refvar $refvars { + upvar $refvar internal_property_reference + #puts stderr " - - b vidx: $vidx" + + #!? could be object not list?? + #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? + #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) + #There would still be an edge case of an initial write of a list of objects of length 1. + if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { + error "untested review!" + #the o_prop is object-shaped + #assumes object has a defaultmethod which accepts indices + set newval [[set $SYNCVARIABLE] {*}$vidx] + + } else { + set newval [lindex $SYNCVARIABLE {*}$vidx] + #if {[set $refvar] ne $newval} { + # set $refvar $newval + #} + if {$internal_property_reference ne $newval} { + set internal_property_reference $newval + } + + } + #puts stderr "=b=> updated $refvar" + } + + + } + + + + } else { + #no vidx + + if {$vtracedIsArray} { + + + foreach refvar $refvars { + set targetref_tail [namespace tail $refvar] + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + + #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" + if {$targetref_is_indexed} { + #curried array item ref of the form ${prop}+x or ${prop}+x+y etc + + #unindexed write on a property that is acting as an array.. + + #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. + + #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). + # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. + puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" + } else { + #How do we know what to write to array ref? + puts stderr "\tc.2 WARNING: unimplemented/unused?" + #error no_tests_for_branch + + #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation + #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate + array unset ${refvar} + array set ${refvar} [array get SYNCVARIABLE] + } + } + + + + } else { + foreach refvar $refvars { + #puts stderr "\t\t_________________[namespace current]" + set targetref_tail [namespace tail $refvar] + upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + if {$targetref_is_indexed} { + #puts "XXXXXXXXX vtraced:$vtraced" + #reference curried with index(es) + #we only set indexed refs if value has changed + # - this not required to be consistent with standard list-containing variable traces, + # as normally list elements can't be traced seperately anyway. + # + + + #only bother checking a ref if no setVia index + # i.e some operation on entire variable so need to test synchronisation for each element-ref + set targetref_indices [lrange [split $targetref_tail +] 1 end] + set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] + #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal + #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" + } + + + } else { + #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! + + #puts stderr "- d2 set" + #puts "refvar: [set $refvar]" + #puts "SYNCVARIABLE: $SYNCVARIABLE" + + #if {[set $refvar] ne $SYNCVARIABLE} { + # set $refvar $SYNCVARIABLE + #} + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE + } + + } + } + + + } + + } + + + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names predator_traces] { + foreach tinfo $predator_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + foreach rv [array names external_traces] { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + + +} + +# end propvar_write_TraceHandler + + + + + + + + + + + + + + + + +# + +#returns 0 if method implementation not present for interface +proc ::p::predator::method_chainhead {iid method} { + #Interface proc + # examine the existing command-chain + set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex) + set cmdchain [list] + + set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}] + set maxversion 0 + #loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob. + foreach test [lsort -dictionary $candidates] { + set c [namespace tail $test] + if {[regexp $re $c _match version]} { + lappend cmdchain $c + if {$version > $maxversion} { + set maxversion $version + } + } + } + return $maxversion +} + + + + + +#this returns a script that upvars vars for all interfaces on the calling object - +# - must be called at runtime from a method +proc ::p::predator::upvar_all {_ID_} { + #::set OID [lindex $_ID_ 0 0] + ::set OID [::lindex [::dict get $_ID_ i this] 0 0] + ::set decl {} + #[set ::p::${OID}::_meta::map] + #[dict get [lindex [dict get $_ID_ i this] 0 1] map] + + ::upvar #0 ::p::${OID}::_meta::map MAP + #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" + #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] + + ::foreach ifid [dict get $MAP interfaces level0] { + if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} { + ::array unset nsvars + ::array set nsvars [::list] + ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { + ::set varspace [::dict get $vinfo varspace] + ::lappend nsvars($varspace) $vname + } + #nsvars now contains vars grouped by varspace. + + ::foreach varspace [::array names nsvars] { + if {$varspace eq ""} { + ::set ns ::p::${OID} + } else { + if {[::string match "::*" $varspace]} { + ::set ns $varspace + } else { + ::set ns ::p::${OID}::$varspace + } + } + + ::append decl "namespace upvar $ns " + ::foreach vname [::set nsvars($varspace)] { + ::append decl "$vname $vname " + } + ::append decl " ;\n" + } + ::array unset nsvars + } + } + ::return $decl +} + +#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator) +proc ::p::predator::runtime_vardecls {} { + set result "::eval \[::p::predator::upvar_all \$_ID_\]" + #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" + + #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" + #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" + #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" + return $result +} + + + + + + +#OBSOLETE!(?) - todo - move stuff out of here. +proc ::p::predator::compile_interface {IFID caller_ID_} { + upvar 0 ::p::${IFID}:: IFACE + + #namespace eval ::p::${IFID} { + # namespace ensemble create + #} + + #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables + + namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + #set varDecls {} + #if {[llength $o_variables]} { + # #puts "*********!!!! $vlist" + # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] " + # foreach vdef $o_variables { + # append varDecls "[lindex $vdef 0] [lindex $vdef 0] " + # } + # append varDecls \n + #} + + #runtime gathering of vars from other interfaces. + #append varDecls [runtime_vardecls] + + set varDecls [runtime_vardecls] + + + + #implement methods + + #!todo - avoid globs on iface array? maintain list of methods in another slot? + #foreach {n mname} [array get IFACE m-1,name,*] {} + + + #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. + + + + #implement property getters/setters/unsetters + #'setter' overrides + #pw short for propertywrite + foreach {n property} [array get IFACE pw,name,*] { + if {[string length $property]} { + #set property [lindex [split $n ,] end] + + #!todo - next_script + #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] + + set maxversion [::p::predator::method_chainhead $IFID (SET)$property] + set chainhead [expr {$maxversion + 1}] + set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 + + set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? + + set body $IFACE(pw,body,$property) + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" + } + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + set maxversion [::p::predator::method_chainhead $IFID $property] + set headid [expr {$maxversion + 1}] + + proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body + + interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid + + #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body + } + } + #'unset' overrides + + dict for {property handler_info} $o_propertyunset_handlers { + + set body [dict get $handler_info body] + set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array + + set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? + + + + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body" + + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + + #implement + #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern "_dontcare_" + } + proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body + + + #chainhead pointer + interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid + } + + + + interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) + + #the usual case will have no destructor - so use info exists to check. + + if {[info exists ::p::${IFID}::_iface::o_destructor_body]} { + #!todo - chained destructors (support @next@). + #set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID] + set next NEXT + + set body [set ::p::${IFID}::_iface::o_destructor_body] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body" + } + #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + proc ::p::${IFID}::___system___destructor _ID_ $body + } + + + if {[info exists o_unknown]} { + #use 'apply' somehow? + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + + #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] + } + + + return +} + + + + + + + +#'info args' - assuming arbitrary chain of 'interp aliases' +proc ::p::predator::command_info_args {cmd} { + if {[llength [set next [interp alias {} $cmd]]]} { + set curriedargs [lrange $next 1 end] + + if {[catch {set arglist [info args [lindex $next 0]]}]} { + set arglist [command_info_args [lindex $next 0]] + } + #trim curriedargs + return [lrange $arglist [llength $curriedargs] end] + } else { + info args $cmd + } +} + + +proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { + if {[llength $args]} { + tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args + } else { + if {[llength $nextArgs] > 1} { + set argVals [::list] + set i 0 + foreach arg [lrange $nextArgs 1 end] { + upvar 1 $arg $i + if {$arg eq "args"} { + #need to check if 'args' is actually available in caller + if {[info exists $i]} { + set argVals [concat $argVals [set $i]] + } + } else { + lappend argVals [set $i] + } + } + tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals + } else { + tailcall ::p::${IFID}::_iface::$mname $_ID_ + } + } +} + +#---------------------------------------------------------------------------------------------- +proc ::p::predator::next_script {IFID method caller caller_ID_} { + + if {$caller eq "(CONSTRUCTOR).1"} { + return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}] + } elseif {$caller eq "$method.1"} { + #delegate to next interface lower down the stack which has a member named $method + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } elseif {[string match "(GET)*.2" $caller]} { + # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. + + #jmn + set prop [string trimright $caller 1234567890] + set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing . + + if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} { + #return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}] + return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] + } else { + #we can actually have a property read without a property or a method of that name - but it could also match the name of a method. + # (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something) + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } + } elseif {[string match "(SET)*.2" $caller]} { + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } else { + #this branch will also handle (SET)*.x and (GET)*.x where x >2 + + #puts stdout "............next_script IFID:$IFID method:$method caller:$caller" + set callerid [string range $caller [string length "$method."] end] + set nextid [expr {$callerid - 1}] + + if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} { + #not a proc directly on this interface - presumably an alias made by something like linkcopy_interface. + #puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid" + set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid] + } + + return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] + } +} + +proc ::p::predator::do_next_if {_ID_ IFID method args} { + #puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' (((" + + #set invocants [dict get $_ID_ i] + #set this_invocantdata [lindex [dict get $invocants this] 0] + #lassign $this_invocantdata OID this_info + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set interfaces [dict get $MAP interfaces level0] + set patterninterfaces [dict get $MAP interfaces level1] + + set L0_posn [lsearch $interfaces $IFID] + if {$L0_posn == -1} { + error "(::p::predator::do_next_if) called with interface not present at level0 for this object" + } elseif {$L0_posn > 0} { + #set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack + set lower_interfaces [lrange $interfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {[string match "(GET)*" $method]} { + #do not test o_properties here! We need to call even if there is no underlying property on this interface + #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) + # relevant test: higher_order_propertyread_chaining + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + } elseif {[string match "(SET)*" $method]} { + #must be called even if there is no matching $method in o_properties + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + } elseif {[string match "(UNSET)*" $method]} { + #review untested + #error "do_next_if (UNSET) untested" + #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'" + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + + } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} { + if {[llength $args]} { + #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args" + + #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args + + #!todo - handle case where llength $args is less than number of args for subinterface command + #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set) + + #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature) + set head [interp alias {} ::p::${if_sub}::_iface::$method] + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc + set argx [list] + foreach a $nextArgs { + lappend argx "\$a" + } + + #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared + + if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} { + tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args + } else { + #todo - upvars required for tail end of arglist + tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args + } + + } else { + #auto-set: upvar vars from calling scope + #!todo - robustify? alias not necessarily matching command name.. + set head [interp alias {} ::p::${if_sub}::_iface::$method] + + + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc + if {[llength $nextArgs] > 1} { + set argVals [::list] + set i 0 + foreach arg [lrange $nextArgs 1 end] { + upvar 1 $arg $i + if {$arg eq "args"} { + #need to check if 'args' is actually available in caller + if {[info exists $i]} { + set argVals [concat $argVals [set $i]] + } + } else { + lappend argVals [set $i] + } + } + #return [$head $_ID_ {*}$argVals] + tailcall $head $_ID_ {*}$argVals + } else { + #return [$head $_ID_] + tailcall $head $_ID_ + } + } + } elseif {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + #return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args] + xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } +} + + +#only really makes sense for (CONSTRUCTOR) calls. +#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class. +proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { + #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" + + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + #set OID [lindex [dict get $invocants this] 0 0] + #upvar #0 ::p::${OID}::_meta::map map + #lassign [lindex $map 0] OID alias itemCmd cmd + + + set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] + upvar #0 ::p::${caller_OID}::_meta::map callermap + + #set interfaces [lindex $map 1 0] + set patterninterfaces [dict get $callermap interfaces level1] + + set L0_posn [lsearch $patterninterfaces $IFID] + if {$L0_posn == -1} { + error "do_next_pattern_if called with interface not present at level1 for this object" + } elseif {$L0_posn > 0} { + + + set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } +} + + + + + +#------------------------------------------------------------------------------------------------ + + + + + +#------------------------------------------------------------------------------------- +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### + + +#!todo - can we just call new_object somehow to create this? + + #until we have a version of Tcl that doesn't have 'creative writing' scope issues - + # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. + # (see http://mini.net/tcl/1030 'Dangers of creative writing') +namespace eval ::p::-1 { + #namespace ensemble create + + namespace eval _ref {} + namespace eval _meta {} + + namespace eval _iface { + variable o_usedby + variable o_open + variable o_constructor + variable o_variables + variable o_properties + variable o_methods + variable o_definition + variable o_varspace + variable o_varspaces + + array set o_usedby [list i0 1] ;#!todo - review + #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? + + set o_open 1 + set o_constructor [list] + set o_variables [list] + set o_properties [dict create] + set o_methods [dict create] + array set o_definition [list] + set o_varspace "" + set o_varspaces [list] + } +} + + +# + +#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}] +interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}] + + +upvar #0 ::p::-1::_iface::o_definition def + + +#! concatenate -> compose ?? +dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}} +proc ::p::-1::Concatenate {_ID_ target args} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {![string match "::*" $target]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set target ::$target + } else { + set target ${ns}::$target + } + } + #add > character if not already present + set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] + set _target [string map {::> ::} $target] + + set ns [namespace qualifiers $target] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } + + if {![llength [info commands $target]]} { + #degenerate case - target does not exist + #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone' + #review - should be 'Copy' so it has object state from namespaces and variables? + return [::p::-1::Clone $_ID_ $target {*}$args] + + #set TARGETMAP [::p::predator::new_object $target] + #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd + + } else { + #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] + set TARGETMAP [$target --] + + lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd + + #Merge lastmodified(?) level0 and level1 interfaces. + + } + + return $target +} + + + +#Object's Base-Interface proc with itself as curried invocant. +#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant +#namespace eval ::p::-1 {namespace export Create} +dict set ::p::-1::_iface::o_methods Define {arglist definitions} +#define objects in one step +proc ::p::-1::Define {_ID_ definitions} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias default_method cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + + #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack + #set IFID0 [lindex $interfaces 0] + #set IFID1 [lindex $patterns 0] ;#1st pattern + + #set IFID_TOP [lindex $interfaces end] + set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] + + #set ns ::p::${OID} + + #set script [string map [list %definitions% $definitions] { + # if {[lindex [namespace path] 0] ne "::p::-1"} { + # namespace path [list ::p::-1 {*}[namespace path]] + # } + # %definitions% + # namespace path [lrange [namespace path] 1 end] + # + #}] + + set script [string map [list %id% $_ID_ %definitions% $definitions] { + set ::p::-1::temp_unknown [namespace unknown] + + namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] + + + #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] + + + %definitions% + + + namespace unknown ${::p::-1::temp_unknown} + return + }] + + + + #uplevel 1 $script ;#this would run the script in the global namespace + #run script in the namespace of the open interface, this allows creating of private helper procs + #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack + #namespace inscope ::p::${OID} $script + namespace eval ::p::${OID} $script + #return $cmd +} + + +proc ::p::predator::redirect {func args} { + + #todo - review tailcall - tests? + if {![llength [info commands ::p::-1::$func]]} { + #error "invalid command name \"$func\"" + tailcall uplevel 1 [list ::unknown $func {*}$args] + } else { + tailcall uplevel 1 [list ::p::-1::$func {*}$args] + } +} + + +#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review. +dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}} +proc ::p::-1::Construct {_ID_ argpairs body args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace + + set ARGSETTER {} + foreach {argname argval} $argpairs { + append ARGSETTER "set $argname $argval\n" + } + #$_self (VIOLATE) $ARGSETTER$body + + set body $ARGSETTER\n$body + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + # puts stderr "\t runtime_vardecls in Construct $varDecls" + } + + set next "\[error {next not implemented}\]" + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + #namespace eval ::p::${iid_top} $body + + #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] + #does this handle Varspace before constructor? + return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] +} + + + + + +#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects +namespace eval ::p::3 {} +proc ::p::3::_create {child {OID "-2"}} { + #puts stderr "::p::3::_create $child $OID" + set _child [string map {::> ::} $child] + if {$OID eq "-2"} { + #set childmapdata [::p::internals::new_object $child] + #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] + set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } else { + set child_ID $OID + #set _childmap [::p::internals::new_object $child "" $child_ID] + ::p::internals::new_object $child "" $child_ID + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } + + #-------------- + + set oldinterfaces [dict get $CHILDMAP interfaces] + dict set oldinterfaces level0 [list 2] + set modifiedinterfaces $oldinterfaces + dict set CHILDMAP interfaces $modifiedinterfaces + + #-------------- + + + + + #puts stderr ">>>> creating alias for ::p::$child_ID" + #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" + + #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! + #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] + #puts stderr ">>>[interp alias {} ::p::$child_ID]" + + + + #--------------- + namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties + foreach method [dict keys $o_methods] { + #todo - change from interp alias to context proc + interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method + } + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop + + } + ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] + #--------------- + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + return $child +} + +#configure -prop1 val1 -prop2 val2 ... +dict set ::p::-1::_iface::o_methods Configure {arglist args} +proc ::p::-1::Configure {_ID_ args} { + + #!todo - add tests. + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd this + + if {![expr {([llength $args] % 2) == 0}]} { + error "expected even number of Configure args e.g '-property1 value1 -property2 value2'" + } + + #Do a separate loop to check all the arguments before we run the property setting loop + set properties_to_configure [list] + foreach {argprop val} $args { + if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} { + error "expected Configure args in the form: '-property1 value1 -property2 value2'" + } + lappend properties_to_configure [string range $argprop 1 end] + } + + #gather all valid property names for all level0 interfaces in the relevant interface stack + set valid_property_names [list] + set iflist [dict get $MAP interfaces level0] + foreach id [lreverse $iflist] { + set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]] + foreach if_prop $interface_property_names { + if {$if_prop ni $valid_property_names} { + lappend valid_property_names $if_prop + } + } + } + + foreach argprop $properties_to_configure { + if {$argprop ni $valid_property_names} { + error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names" + } + } + + set top_IID [lindex $iflist end] + #args ok - go ahead and set all properties + foreach {prop val} $args { + set property [string range $prop 1 end] + #------------ + #don't use property ref unnecessarily - leaves property refs hanging around which traces need to update + #ie don't do this here: set [$this . $property .] $val + #------------- + ::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val] + } + return +} + + + + + + +dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid} +proc ::p::-1::AddPatternInterface {_ID_ iid} { + #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces + + + + #it is theoretically possible to have the same interface present multiple times in an iStack. + # #!todo -review why/whether this is useful. should we disallow it and treat as an error? + + lappend existing_ifaces $iid + #lset map {1 1} $existing_ifaces + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + + #lset invocant {1 1} $existing_ifaces + +} + + +#!todo - update usedby ?? +dict set ::p::-1::_iface::o_methods AddInterface {arglist iid} +proc ::p::-1::AddInterface {_ID_ iid} { + #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + + lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. + set this_invocant [lindex $list_of_invocants_for_role_this 0] + + lassign $this_invocant OID _etc + + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level0] + + lappend existing_ifaces $iid + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + return [dict get $extracted_sub_dict level0] +} + + + +# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module. +# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist +# and 'CreateOverlay' for the case where the target/child object already exists. +# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence, +# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object. +# 'CreateNew' will raise an error if the target already exists +# 'CreateOverlay' will raise an error if the target object does not exist. +# 'Create' will work in either case. Creating the target if necessary. + + +#simple form: +# >somepattern .. Create >child +#simple form with arguments to the constructor: +# >somepattern .. Create >child arg1 arg2 etc +#complex form - specify more info about the target (dict keyed on childobject name): +# >somepattern .. Create {>child {-id 1}} +#or +# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] +#complex form - with arguments to the contructor: +# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc +dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}} +proc ::p::-1::Create {_ID_ target_spec args} { + #$args are passed to constructor + if {[llength $target_spec] ==1} { + set child $target_spec + set targets [list $child {}] + } else { + set targets $target_spec + } + + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) + + foreach {child target_spec_dict} $targets { + #puts ">>>::p::-1::Create $_ID_ $child $args <<<" + + + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + + + + #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID" + + #child should already be fully ns qualified (?) + #ensure it is has a pattern-object marker > + #puts stderr ".... $child (nsqual: [namespace qualifiers $child])" + + + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + #puts "parent: $OID -> child:$child Patterns $patterns" + + #todo - change to dict of interface stacks + set IFID0 [lindex $interfaces 0] + set IFID1 [lindex $patterns 0] ;#1st pattern + + #upvar ::p::${OID}:: INFO + + if {![string match {::*} $child]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set child ::$child + } else { + set child ${ns}::$child + } + } + + + #add > character if not already present + set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >] + set _child [string map {::> ::} $child] + + set ns [namespace qualifiers $child] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } + + + #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls. + set new_interfaces [list] + + if {![llength $patterns]} { + ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child" + #lappend patterns [::p::internals::new_interface $OID] + + #lset invocant {1 1} $patterns + ##update our command because we changed the interface list. + #set IFID1 [lindex $patterns 0] + + #set patterns [list [::p::internals::new_interface $OID]] + + #set patterns [list [::p::internals::new_interface]] + + #set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id + #set patterns [list [set iid [incr ::p::ID]]] + set patterns [list [set iid [::p::get_new_object_id]]] + + #--------- + #set iface [::p::>interface .. Create ::p::ifaces::>$iid] + #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid + + #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation + lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid] + + #--------- + + #puts "??> p::>interface .. Create ::p::ifaces::>$iid" + #puts "??> [::p::ifaces::>$iid --]" + #set [$iface . UsedBy .] + } + set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] + + #if {![llength [info commands $child]]} {} + + if {[namespace which $child] eq ""} { + #normal case - target/child does not exist + set is_new_object 1 + + if {[dict exists $target_spec_dict -id]} { + set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]] + } else { + set childmapdata [::p::internals::new_object $child] + } + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + + + + #child initially uses parent's level1 interface as it's level0 interface + # child has no level1 interface until PatternMethods or PatternProperties are added + # (or applied via clone; or via create with a parent with level2 interface) + #set child_IFID $IFID1 + + #lset CHILDMAP {1 0} [list $IFID1] + #lset CHILDMAP {1 0} $patterns + + set extracted_sub_dict [dict get $CHILDMAP interfaces] + dict set extracted_sub_dict level0 $patterns + dict set CHILDMAP interfaces $extracted_sub_dict + + #why write back when upvared??? + #review + set ::p::${child_ID}::_meta::map $CHILDMAP + + #::p::predator::remap $CHILDMAP + + #interp alias {} $child {} ::p::internals::predator $CHILDMAP + + #set child_IFID $IFID1 + + #upvar ::p::${child_ID}:: child_INFO + + #!todo review + #set n ::p::${child_ID} + #if {![info exists ${n}::-->PATTERN_ANCHOR]} { + # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" + # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack + # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" + # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] + #} + + set ifaces_added $patterns + + } else { + #overlay/mixin case - target/child already exists + set is_new_object 0 + + #set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1] + set childmapdata [$child --] + + + #puts stderr " *** $cmd .. Create -> target $child already exists!!!" + #puts " **** CHILDMAP: $CHILDMAP" + #puts " ****" + + #puts stderr " ---> Properties: [$child .. Properties . names]" + #puts stderr " ---> Methods: [$child .. Properties . names]" + + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + + #set child_IFID [lindex $CHILDMAP 1 0 end] + #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} { + # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] + # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP + #} + ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces + #::p::merge_interface $IFID1 $child_IFID + + + set existing_interfaces [dict get $CHILDMAP interfaces level0] + set ifaces_added [list] + foreach p $patterns { + if {$p ni $existing_interfaces} { + lappend ifaces_added $p + } + } + + if {[llength $ifaces_added]} { + #lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added] + set extracted_sub_dict [dict get $CHILDMAP interfaces] + dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added] + dict set CHILDMAP interfaces $extracted_sub_dict + #set ::p::${child_ID}::_meta::map $CHILDMAP ;#why? + #::p::predator::remap $CHILDMAP + } + } + + #do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty + if {$parent_patterndefaultmethod ne ""} { + set child_defaultmethod $parent_patterndefaultmethod + set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata] + lset CHILD_INVOCANTDATA 2 $child_defaultmethod + dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA + #update the child's _ID_ + interp alias {} $child_alias {} ;#first we must delete it + interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}] + + #! object_command was initially created as the renamed alias - so we have to do it again + rename $child_alias $child + trace add command $child rename [list $child .. Rename] + } + #!todo - review - dont we already have interp alias entries for every method/prop? + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + + + + + + set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call. + + + + #------------------------------------------------------------------------------------ + #create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail. + # - All variables under the namespace - not just those declared as Variables or Properties + # - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces. + # - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write. + + #NOTE - do not use the objectID as the sole identifier for the snapshot namespace. + # - there may be multiple active snapshots for a single object if it overlays itself during a constructor, + # and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call. + # - we will use an ever-increasing snapshotid to form part of ns_snap + set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create. + + #!todo - this should look at child namespaces (recursively?) + #!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces. + # (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace) + + namespace eval $ns_snap {} + foreach vname [info vars ::p::${child_ID}::*] { + set shortname [namespace tail $vname] + if {[array exists $vname]} { + array set ${ns_snap}::${shortname} [array get $vname] + } elseif {[info exists $vname]} { + set ${ns_snap}::${shortname} [set $vname] + } else { + #variable exists without value (e.g created by 'variable' command) + namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist' + } + } + #------------------------------------------------------------------------------------ + + + + + + + + + + #puts "====>>> ifaces_added $ifaces_added" + set idx 0 + set idx_count [llength $ifaces_added] + set highest_constructor_IFID "" + foreach IFID $ifaces_added { + incr idx + #puts "--> adding iface $IFID " + namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + if {[llength $o_varspaces]} { + foreach vs $o_varspaces { + #ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work. + if {[string match "::*" $vs]} { + namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all. + } else { + namespace eval ::p::${child_ID}::$vs {} + } + } + } + + if {$IFID != 2} { + #>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list. + if {![info exists o_usedby(i$child_ID)]} { + set o_usedby(i$child_ID) $child_alias + } + + #compile and close the interface only if it is shared + if {$o_open} { + ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_ + set o_open 0 + } + } + + + + package require struct::set + + set propcmds [list] + foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] { + set cmd [namespace tail $cmd] + #may contain multiple results for same prop e.g (GET)x.3 + set cmd [string trimright $cmd 0123456789] + set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals + lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. + } + set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. + #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. + foreach property $propcmds { + #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n" + interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces + interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property + } + + set propcmds [list] + foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] { + set cmd [namespace tail $cmd] + #may contain multiple results for same prop e.g (GET)x.3 + set cmd [string trimright $cmd 0123456789] + set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals + lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. + } + set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. + #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. + foreach property $propcmds { + interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces + } + + + foreach method [dict keys $o_methods] { + set arglist [dict get $o_methods $method arglist] + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + + #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method + + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #proc calls the method in the interface - which is an interp alias to the head of the implementation chain + + + proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IFID}::_iface::$method \$_ID_ $argvals + }] + + #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] { + # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ + #}] + + + } + + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + set varspace [dict get $pdef varspace] + if {![string length $varspace]} { + set ns ::p::${child_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${child_ID}::$varspace + } + } + if {[dict exists $pdef default]} { + if {![info exists ${ns}::o_$prop]} { + #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) + set ${ns}::o_$prop [dict get $pdef default] + } + } + #! May be replaced by a method with the same name + if {$prop ni [dict keys $o_methods]} { + interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop + } + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop + } + + + + #variables + #foreach vdef $o_variables { + # if {[llength $vdef] == 2} { + # #there is a default value defined. + # lassign $vdef v default + # if {![info exists ::p::${child_ID}::$v]} { + # set ::p::${child_ID}::$v $default + # } + # } + #} + dict for {vname vdef} $o_variables { + if {[dict exists $vdef default]} { + #there is a default value defined. + set varspace [dict get $vdef varspace] + if {$varspace eq ""} { + set ns ::p::${child_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${child_ID}::$varspace + } + } + set ${ns}::$vname [dict get $vdef default] + } + } + + + #!todo - review. Write tests for cases of multiple constructors! + + #We don't want to the run constructor for each added interface with the same set of args! + #run for last one - rely on constructor authors to use @next@ properly? + if {[llength [set ::p::${IFID}::_iface::o_constructor]]} { + set highest_constructor_IFID $IFID + } + + if {$idx == $idx_count} { + #we are processing the last interface that was added - now run the latest constructor found + if {$highest_constructor_IFID ne ""} { + #at least one interface has a constructor + if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} { + #puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP" + if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} { + set constructor_failure 1 + set constructor_errorInfo $::errorInfo ;#cache it immediately. + break + } + } + } + } + + if {[info exists o_unknown]} { + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + + + #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] + #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown] + } + } + + if {$constructor_failure} { + if {$is_new_object} { + #is Destroy enough to ensure that no new interfaces or objects were left dangling? + $child .. Destroy + } else { + #object needs to be returned to a sensible state.. + #attempt to rollback all interface additions and object state changes! + puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n" + #remove variables from the object's namespace - which don't exist in the snapshot. + set snap_vars [info vars ${ns_snap}::*] + puts "ns_snap '$ns_snap' vars'${snap_vars}'" + foreach vname [info vars ::p::${child_ID}::*] { + set shortname [namespace tail $vname] + if {"${ns_snap}::$shortname" ni "$snap_vars"} { + #puts "--- >>>>> unsetting $shortname " + unset -nocomplain $vname + } + } + + #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces) + #values of vars may also have Changed + #todo - consider traces? what is the correct behaviour? + # - some application traces may have fired before the constructor error occurred. + # Should the rollback now also trigger traces? + #probably yes. + + #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value + foreach vname $snap_vars { + #puts stdout "@@@@@@@@@@@ restoring $vname" + #flush stdout + + + set shortname [namespace tail $vname] + set target ::p::${child_ID}::$shortname + if {$target in [info vars ::p::${child_ID}::*]} { + set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only' + } else { + set present 0 + } + + if {[array exists $vname]} { + #restore 'array' variable + if {!$present} { + array set $target [array get $vname] + } else { + if {[array exists $target]} { + #unset superfluous elements + foreach key [array names $target] { + if {$key ni [array names $vname]} { + array unset $target $key + } + } + #.. and write only elements that have changed. + foreach key [array names $vname] { + if {[set ${target}($key)] ne [set ${vname}($key)]} { + set ${target}($key) [set ${vname}($key)] + } + } + } else { + #target has been changed to a simple variable - unset it and recreate the array. + unset $target + array set $target [array get $vname] + } + } + } elseif {[info exists $vname]} { + #restore 'simple' variable + if {!$present} { + set $target [set $vname] + } else { + if {[array exists $target]} { + #target has been changed to array - unset it and recreate the simple variable. + unset $target + set $target [set $vname] + } else { + if {[set $target] ne [set $vname]} { + set $target [set $vname] + } + } + } + } else { + #restore 'declared' variable + if {[array exists $target] || [info exists $target]} { + unset -nocomplain $target + } + namespace eval ::p::${child_ID} [list variable $shortname] + } + } + } + namespace delete $ns_snap + return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error + } + namespace delete $ns_snap + + } + + + + return $child +} + +dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} +#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied* +# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*) +# Also: Any 'open' interfaces on the parent become closed on clone! +proc ::p::-1::Clone {_ID_ clone args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set invocants [dict get $_ID_ i] + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + + set _cmd [string map {::> ::} $cmd] + set tail [namespace tail $_cmd] + + + #obsolete? + ##set IFID0 [lindex $map 1 0 end] + #set IFID0 [lindex [dict get $MAP interfaces level0] end] + ##set IFID1 [lindex $map 1 1 end] + #set IFID1 [lindex [dict get $MAP interfaces level1] end] + + + if {![string match "::*" $clone]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set clone ::$clone + } else { + set clone ${ns}::$clone + } + } + + + set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] + set _clone [string map {::> ::} $clone] + + + set cTail [namespace tail $_clone] + + set ns [namespace qualifiers $clone] + if {$ns eq ""} { + set ns "::" + } + + namespace eval $ns {} + + + #if {![llength [info commands $clone]]} {} + if {[namespace which $clone] eq ""} { + set clonemapdata [::p::internals::new_object $clone] + } else { + #overlay/mixin case - target/clone already exists + #set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1] + set clonemapdata [$clone --] + } + set clone_ID [lindex [dict get $clonemapdata invocantdata] 0] + + upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP + + + #copy patterndata element of MAP straight across + dict set CLONEMAP patterndata [dict get $MAP patterndata] + set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata] + lset CLONE_INVOCANTDATA 2 $parent_defaultmethod + dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA + lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone + + #update the clone's _ID_ + interp alias {} $clone_alias {} ;#first we must delete it + interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}] + + #! object_command was initially created as the renamed alias - so we have to do it again + rename $clone_alias $clone + trace add command $clone rename [list $clone .. Rename] + + + + + #obsolete? + #upvar ::p::${clone_ID}:: clone_INFO + #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. + #upvar ::p::${OID}:: INFO + + + array set clone_INFO [array get INFO] + + array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' + + + #!review! + #if {![catch {set itemCmd $IFACE(m-1,name,item)}]} { + #puts "***************" + #puts "clone" + #parray IFINFO + #puts "***************" + #} + + #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern + + + #clone's interface maps must be a superset of original's + foreach lev {0 1} { + #set parent_ifaces [lindex $map 1 $lev] + set parent_ifaces [dict get $MAP interfaces level$lev] + + #set existing_ifaces [lindex $CLONEMAP 1 $lev] + set existing_ifaces [dict get $CLONEMAP interfaces level$lev] + + set added_ifaces_$lev [list] + foreach ifid $parent_ifaces { + if {$ifid ni $existing_ifaces} { + + #interface must not remain extensible after cloning. + if {[set ::p::${ifid}::_iface::o_open]} { + ::p::predator::compile_interface $ifid $_ID_ + set ::p::${ifid}::_iface::o_open 0 + } + + + + lappend added_ifaces_$lev $ifid + #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. + set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone + } + } + set extracted_sub_dict [dict get $CLONEMAP interfaces] + dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]] + dict set CLONEMAP interfaces $extracted_sub_dict + #lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]] + } + + #interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE) + + + #foreach *added* level0 interface.. + foreach ifid $added_ifaces_0 { + namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown + + + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + if {[dict exists $pdef default]} { + set varspace [dict get $pdef varspace] + if {$varspace eq ""} { + set ns ::p::${clone_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${clone_ID}::$varspace + } + } + + if {![info exists ${ns}::o_$prop]} { + #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) + set ${ns}::o_$prop [dict get $pdef default] + } + } + + #! May be replaced by method of same name + if {[namespace which ::p::${clone_ID}::$prop] eq ""} { + interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop + } + interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop + interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop + } + + #variables + dict for {vname vdef} $o_variables { + if {[dict exists $vdef default]} { + set varspace [dict get $vdef varspace] + if {$varspace eq ""} { + set ns ::p::${clone_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${clone_ID}::$varspace + } + } + if {![info exists ${ns}::$vname]} { + set ::p::${clone_ID}::$vname [dict get $vdef default] + } + } + } + + + #update the clone object's base interface to reflect the new methods. + #upvar 0 ::p::${ifid}:: IFACE + #set methods [list] + #foreach {key mname} [array get IFACE m-1,name,*] { + # set method [lindex [split $key ,] end] + # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP + # lappend methods $method + #} + #namespace eval ::p::${clone_ID} [list namespace export {*}$methods] + + + foreach method [dict keys $o_methods] { + + set arglist [dict get $o_methods $method arglist] + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method + + + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #proc calls the method in the interface - which is an interp alias to the head of the implementation chain + proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${ifid}::_iface::$method \$_ID_ $argvals + }] + + } + #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods] + + + if {[info exists o_unknown]} { + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown + interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + + #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown] + #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown] + + } + + + #2021 + #Consider >parent with constructor that sets height + #.eg >parent .. Constructor height { + # set o_height $height + #} + #>parent .. Create >child 5 + # - >child has height 5 + # now when we peform a clone operation - it is the >parent's constructor that will run. + # A clone will get default property and var values - but not other variable values unless the constructor sets them. + #>child .. Clone >fakesibling 6 + # - >sibling has height 6 + # Consider if >child had it's own constructor created with .. Construct prior to the clone operation. + # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead. + # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining... + # when we now do >sibling .. Create >grandchild + # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild + # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.) + # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild + #(though other arguments can be manually passed) + # #!review - does this make sense? What if we add + # + #constructor for each interface called after properties initialised. + #run each interface's constructor against child object, using the args passed into this clone method. + if {[llength [set constructordef [set o_constructor]]]} { + #error + puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID" + ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args + + } + + } + + + return $clone + +} + + + +interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?) +dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}} +proc ::p::-1::Constructor {_ID_ arglist body} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #set iid_top [::p::get_new_object_id] + + #the >interface constructor takes a list of IDs for o_usedby + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + + #::p::predator::remap $invocant + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] + set headid [expr {$maxversion + 1}] + set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 + + set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] + + #set varspaces [::pattern::varspace_list] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] + set body $varDecls\n[dict get $processed body] + #puts stderr "\t runtime_vardecls in Constructor $varDecls" + } + + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #puts stderr ---- + #puts stderr $body + #puts stderr ---- + + proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body + interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid + + + + set o_constructor [list $arglist $body] + set o_open 1 + + return +} + + + +dict set ::p::-1::_iface::o_methods UsedBy {arglist {}} +proc ::p::-1::UsedBy {_ID_} { + return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby] +} + + +dict set ::p::-1::_iface::o_methods Ready {arglist {}} +proc ::p::-1::Ready {_ID_} { + return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}] +} + + + +dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}} + +#'force' 1 indicates object command & variable will also be removed. +#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var. +#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4) +# +proc ::p::-1::Destroy {_ID_ {force 1}} { + #puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]" + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + + if {$OID eq "null"} { + puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" + return + } + + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout + + #explicit Destroy - remove traces + #puts ">>TRACES: [trace info variable $cmd]" + #foreach tinfo [trace info variable $cmd] { + # trace remove variable $cmd {*}$tinfo + #} + #foreach tinfo [trace info command $cmd] { + # trace remove command $cmd {*}$tinfo + #} + + + set _cmd [string map {::> ::} $cmd] + + #set ifaces [lindex $map 1] + set iface_stacks [dict get $MAP interfaces level0] + #set patterns [lindex $map 2] + set pattern_stacks [dict get $MAP interfaces level1] + + + + set ifaces $iface_stacks + + + set patterns $pattern_stacks + + + #set i 0 + #foreach iflist $ifaces { + # set IFID$i [lindex $iflist 0] + # incr i + #} + + + set IFTOP [lindex $ifaces end] + + set DESTRUCTOR ::p::${IFTOP}::___system___destructor + #may be a proc, or may be an alias + if {[namespace which $DESTRUCTOR] ne ""} { + set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] + + if {[catch {$DESTRUCTOR $temp_ID_} prob]} { + #!todo - ensure correct calling order of interfaces referencing the destructor proc + + + #!todo - emit destructor errors somewhere - logger? + #puts stderr "underlying proc already removed??? ---> $prob" + #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" + #puts stderr $::errorInfo + #puts stderr "---------------------" + } + } + + + #remove ourself from each interfaces list of referencers + #puts stderr "--- $ifaces" + + foreach var {ifaces patterns} { + + foreach i [set $var] { + + if {[string length $i]} { + if {$i == 2} { + #skip the >ifinfo interface which doesn't maintain a usedby list anyway. + continue + } + + if {[catch { + + upvar #0 ::p::${i}::_iface::o_usedby usedby + + array unset usedby i$OID + + + #puts "\n***>>***" + #puts "IFACE: $i usedby: $usedby" + #puts "***>>***\n" + + #remove interface if no more referencers + if {![array size usedby]} { + #puts " **************** DESTROYING unused interface $i *****" + #catch {namespace delete ::p::$i} + + #we happen to know where 'interface' object commands are kept: + + ::p::ifaces::>$i .. Destroy + + } + + } errMsg]} { + #warning + puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" + } + } + + } + + } + + set ns ::p::${OID} + #puts "-- destroying objects below namespace:'$ns'" + ::p::internals::DestroyObjectsBelowNamespace $ns + #puts "--.destroyed objects below '$ns'" + + + #set ns ::p::${OID}::_sub + #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace + #( ::p::OBJECT::$OID ) + #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" + #::p::internals::DestroyObjectsBelowNamespace $ns + + #same for _meta objects (e.g Methods,Properties collections) + #set ns ::p::${OID}::_meta + #::p::internals::DestroyObjectsBelowNamespace $ns + + + + #foreach obj [info commands ${ns}::>*] { + # #Assume it's one of ours, and ask it to die. + # catch {::p::meta::Destroy $obj} + # #catch {$cmd .. Destroy} + #} + #just in case the user created subnamespaces.. kill objects there too. + #foreach sub [namespace children $ns] { + # ::p::internals::DestroyObjectsBelowNamespace $sub + #} + + + #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value! + #use info commands ::p::${OID}::_ref::* to find all references - including variables never set + #remove variable traces on REF vars + #foreach rv [info vars ::p::${OID}::_ref::*] { + # foreach tinfo [trace info variable $rv] { + # #puts "-->removing traces on $rv: $tinfo" + # trace remove variable $rv {*}$tinfo + # } + #} + + #!todo - write tests + #refs create aliases and variables at the same place + #- but variable may not exist if it was never set e.g if it was only used with info exists + foreach rv [info commands ::p::${OID}::_ref::*] { + foreach tinfo [trace info variable $rv] { + #puts "-->removing traces on $rv: $tinfo" + trace remove variable $rv {*}$tinfo + } + } + + + + + + + + #if {[catch {namespace delete $nsMeta} msg]} { + # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " + #} else { + # #puts stderr "------ -- -- -- -- deleted $nsMeta " + #} + + + #!todo - remove + #temp + #catch {interp alias "" ::>$OID ""} + + if {$force} { + #rename $cmd {} + + #removing the alias will remove the command - even if it's been renamed + interp alias {} $alias {} + + #if {[catch {rename $_cmd {} } why]} { + # #!todo - work out why some objects don't have matching command. + # #puts stderr "\t rename $_cmd {} failed" + #} else { + # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" + #} + + } + + set refns ::p::${OID}::_ref + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- matching command: [llength [info commands ${refns}]]" + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" + + + #foreach v [info vars ${refns}::*] { + # unset $v + #} + #foreach p [info procs ${refns}::*] { + # rename $p {} + #} + #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { + # interp alias {} $a {} + #} + + + #set ts1 [clock seconds] + #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- exact command: [info commands ${refns}]" + + + + + #puts "--delete ::p::${OID}::_ref" + if {[namespace exists ::p::${OID}::_ref]} { + #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. + namespace delete ::p::${OID}::_ref:: + } + set ts2 [clock seconds] + #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" + + + #delete namespace where instance variables reside + #catch {namespace delete ::p::$OID} + namespace delete ::p::$OID + + #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout + return +} + + +interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility + + +dict set ::p::-1::_iface::o_methods Destructor {arglist {args}} +#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction? +#install a Destructor on the invocant's open level1 interface. +proc ::p::-1::Destructor {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + #lassign [lindex $map 0] OID alias itemCmd cmd + + set patterns [dict get $MAP interfaces level1] + + if {[llength $args] > 2} { + error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" + } + + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + error "NOT TESTED" + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + #::p::predator::remap $invocant + } + + + set ::p::${IID}::_iface::o_destructor_body [lindex $args end] + + if {[llength $args] > 1} { + #!todo - allow destructor args(?) + set arglist [lindex $args 0] + } else { + set arglist [list] + } + + set ::p::${IID}::_iface::o_destructor_args $arglist + + return +} + + + + + +interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit) + + +dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}} +proc ::p::-1::PatternMethod {_ID_ method arglist body} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + + namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 + + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + #puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls" + set body $varDecls\n[dict get $processed body] + #puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls" + } + + + set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist] + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] + #puts "\t\t--------------------" + #puts "\n" + #puts $body + #puts "\n" + #puts "\t\t--------------------" + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + + + #pointer from method-name to head of the interface's command-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + + if {$method in [dict keys $o_methods]} { + #error "patternmethod '$method' already present in interface $IID" + set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)" + if {[string match "*@next@*" $body]} { + append msg "\n EXTRA-WARNING: method contains @next@" + } + + puts stdout $msg + } else { + dict set o_methods $method [list arglist $arglist] + } + + #::p::-1::update_invocant_aliases $_ID_ + return +} + +#MultiMethod +#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants +# e.g1 $obj .. MultiMethod add {these 2} $arglist $body +# e.g2 $obj .. MultiMethod add {these n} $arglist $body +# +# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body +# +# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature. +# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature) +# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces) +# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? +# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed? +# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? +# (and how would we define the call order? - presumably as it appears in the conglomerate) +# (or could that be done with a more general method-wrapping mechanism?) +#...should multimethods use some sort of event mechanism, and/or message-passing system? +# +dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}} +proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { + set invocants [dict get $_ID_ i] + + error "not implemented" +} + +dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} +# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- ) +#we can create a method named "." by using the argprotect operator -- +# e.g >x .. Method -- . {args} $body +#It can then be called like so: >x . . +#This is not guaranteed to work and is not in the test suite +#for now we'll just use a highly unlikely string to indicate no argument was supplied +proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + if {$methodname eq $non_argument_magicstring} { + return $default_method + } else { + set extracted_value [dict get $MAP invocantdata] + lset extracted_value 2 $methodname + dict set MAP invocantdata $extracted_value ;#write modified value back + #update the object's command alias to match + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] + + #! $object_command was initially created as the renamed alias - so we have to do it again + rename $alias $object_command + trace add command $object_command rename [list $object_command .. Rename] + return $methodname + } +} + +dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} +proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set extracted_patterndata [dict get $MAP patterndata] + set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] + if {$methodname eq $non_argument_magicstring} { + return $pattern_default_method + } else { + dict set extracted_patterndata patterndefaultmethod $methodname + dict set MAP patterndata $extracted_patterndata + return $methodname + } +} + + +dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}} +proc ::p::-1::Method {_ID_ method arglist bodydef args} { + set invocants [dict get $_ID_ i] + + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + set invocant_signature [list] ; + ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. + foreach role [lsort [dict keys $invocants]] { + lappend invocant_signature $role [llength [dict get $invocants $role]] + } + #note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this') + + + + lassign [dict get $MAP invocantdata] OID alias default_method object_command + set interfaces [dict get $MAP interfaces level0] + + + + ################################################################################# + if 0 { + set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface + set prev_open [set ::p::${iid_top}::_iface::o_open] + + set iface ::p::ifaces::>$iid_top + + set f_new 0 + if {![string length $iid_top]} { + set f_new 1 + } else { + if {[$iface . isClosed]} { + set f_new 1 + } + } + if {$f_new} { + #create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + + } + set IID $iid_top + + } + ################################################################################# + + set IID [::p::predator::get_possibly_new_open_interface $OID] + + #upvar 0 ::p::${IID}:: IFACE + + namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces + + + #Interface proc + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 + + if {$method ni [dict keys $o_methods]} { + dict set o_methods $method [list arglist $arglist] + } + + #next_script will call to lower interface in iStack if we are $method.1 + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_ + #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<" + + + #implement + #----------------------------------- + set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + set varDecls "" + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + } + + + set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist] + + + + + + + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #if {[string length $varDecls]} { + # puts stdout "\t---------------------------------------------------------------" + # puts stdout "\t----- efficiency warning - implicit var declarations used -----" + # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" + # puts stdout "\t[string map [list \n \t\t\n] $body]" + # puts stdout "\t--------------------------" + #} + #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role + # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. + #(as specified by the @ operator during object conglomeration) + #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] + + #puts stdout "\t\t----------------------------" + #puts stdout "$body" + #puts stdout "\t\t----------------------------" + + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + #----------------------------------- + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + #point to the interface command only. The dispatcher will supply the invocant data + #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IID}::_iface::$method \$_ID_ $argvals + }] + + + if 0 { + if {[llength $argvals]} { + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { + apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ + }] + } else { + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { + apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ + }] + + } + } + + + #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + # ::p::${IID}::_iface::$method \$_ID_ $argvals + #}] + + #todo - for o_varspaces + #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method + #- this should work correctly with the 'uplevel 1' procs in the interfaces + + + if {[string length $o_varspace]} { + if {[string match "::*" $o_varspace]} { + namespace eval $o_varspace {} + } else { + namespace eval ::p::${OID}::$o_varspace {} + } + } + + + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + set colMethods ::p::${OID}::_meta::>colMethods + + if {[namespace which $colMethods] ne ""} { + if {![$colMethods . hasKey $method]} { + $colMethods . add [::p::internals::predator $_ID_ . $method .] $method + } + } + + #::p::-1::update_invocant_aliases $_ID_ + return + #::>pattern .. Create [::>pattern .. Namespace]::>method_??? + #return $method_object +} + + +dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}} +proc ::p::-1::V {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + + + set vlist [list] + foreach IID $ifaces { + dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { + if {[string match $glob $vname]} { + lappend vlist $vname + } + } + } + + + return $vlist +} + +#experiment from http://wiki.tcl.tk/4884 +proc p::predator::pipeline {args} { + set lambda {return -level 0} + foreach arg $args { + set lambda [list apply [dict get { + toupper {{lambda input} {string toupper [{*}$lambda $input]}} + tolower {{lambda input} {string tolower [{*}$lambda $input]}} + totitle {{lambda input} {string totitle [{*}$lambda $input]}} + prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}} + suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}} + } [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]] + } + return $lambda +} + +proc ::p::predator::get_apply_arg_0_oid {} { + set apply_args [lrange [info level 0] 2 end] + puts stderr ">>>>> apply_args:'$apply_args'<<<<" + set invocant [lindex $apply_args 0] + return [lindex [dict get $invocant i this] 0 0] +} +proc ::p::predator::get_oid {} { + #puts stderr "---->> [info level 1] <<-----" + set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 + tailcall lindex [dict get $_ID_ i this] 0 0 +} + +#todo - make sure this is called for all script installations - e.g propertyread etc etc +#Add tests to check code runs in correct namespace +#review - how does 'Varspace' command affect this? +proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} { + #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) + set arglist_apply "" + append arglist_apply "\$_ID_ " + foreach a $arglist { + if {$a eq "args"} { + append arglist_apply "{*}\$args" + } else { + append arglist_apply "\$[lindex $a 0] " + } + } + #!todo - allow fully qualified varspaces + if {[string length $varspace]} { + if {[string match ::* $varspace]} { + return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply" + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n" + return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply" + } + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" + #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" + + set script "tailcall apply \[list \{_ID_" + + if {[llength $arglist]} { + append script " $arglist" + } + append script "\} \{" + append script $body + append script "\} ::p::@OID@\] " + append script $arglist_apply + #puts stderr "\n88888888888888888888888888\n\t$script\n" + #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" + #return $script + + + #----------------------------------------------------------------------------- + # 2018 candidates + # + #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + + + #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) + #faster though. + #return "uplevel 1 \{$body\}" + return "uplevel 1 [list $body]" + #----------------------------------------------------------------------------- + + + + + #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" + #return "uplevel 1 \{$script\}" + + #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + + + + #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong + + #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns + + + #experiment with different dispatch mechanism (interp alias with 'namespace inscope') + #----------- + #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" + + + #return "uplevel 1 \{$body\}" ;#do nothing + + #---------- + + #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) + + #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body + + #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker + + #return "tailcall " + + + } +} + + +#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies. +#expand 'var' statements inline in method bodies +#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements. +# +#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces +#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches! +# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements. +#Think of var & varspace statments as a form of compile-time 'macro' +# +#caters for 2-element lists as arguments to var statement to allow 'aliasing' +#e.g var o_thing {o_data mydata} +# this will upvar o_thing as o_thing & o_data as mydata +# +proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { + set body {} + + #keep count of any explicit var statments per varspace in 'numDeclared' array + # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements. + + #default varspace is "" + #varspace should only have leading :: if it is an absolute namespace path. + + + foreach ln [split $rawbody \n] { + set trimline [string trim $ln] + + if {$trimline eq "var"} { + #plain var statement alone indicates we don't have any explicit declarations in this branch + # and we don't want implicit declarations for the current varspace either. + #!todo - implement test + + incr numDeclared($varspace) + + #may be further var statements e.g - in other code branches + #return [list body $rawbody varspaces_with_explicit_vars 1] + } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { + + #append body " upvar #0 " + #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " + #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " + + if {$varspace eq ""} { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " + } else { + if {[string match "::*" $varspace]} { + append body " namespace upvar $varspace " + } else { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " + } + } + + #any whitespace before or betw var names doesn't matter - about to use as list. + foreach varspec [string range $trimline 4 end] { + lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. + ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " + #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " + + append body "$var $alias " + + } + append body \n + + incr numDeclared($varspace) + } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { + #2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? + #it is assumed there is a single word following the 'varspace' keyword. + set varspace [string trim [string range $trimline 9 end]] + + if {$varspace in [list {{}} {""}]} { + set varspace "" + } + if {[string length $varspace]} { + #set varspace ::${varspace}:: + #no need to initialize numDeclared($varspace) incr will work anyway. + #if {![info exists numDeclared($varspace)]} { + # set numDeclared($varspace) 0 + #} + + if {[string match "::*" $varspace]} { + append body "namespace eval $varspace {} \n" + } else { + append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n" + } + + #puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} " + #append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n" + #append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n" + + #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n" + } + #!review - why? why do we need the magic 'default' name instead of just using the empty string? + #if varspace argument was empty string - leave it alone + } else { + append body $ln\n + } + } + + + + set varspaces [array names numDeclared] + return [list body $body varspaces_with_explicit_vars $varspaces] +} + + + + +#Interface Variables +dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} +proc ::p::-1::IV {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + + #!todo - test + #return [dict keys ::p::${OID}::_iface::o_variables $glob] + + set members [list] + foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { + if {[string match $glob $vname]} { + lappend members $vname + } + } + return $members +} + + +dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}} +proc ::p::-1::Methods {_ID_ {idx ""}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set col ::p::${OID}::_meta::>colMethods + + if {[namespace which $col] eq ""} { + patternlib::>collection .. Create $col + foreach IID $ifaces { + foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { + if {![$col . hasIndex $m]} { + #todo - create some sort of lazy-evaluating method object? + #set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist] + $col . add [::p::internals::predator $_ID_ . $m .] $m + } + } + } + } + + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } +} + +dict set ::p::-1::_iface::o_methods M {arglist {}} +proc ::p::-1::M {_ID_} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set members [list] + foreach IID $ifaces { + foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { + lappend members $m + } + } + return $members +} + + +#review +#Interface Methods +dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}} +proc ::p::-1::IM {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] + +} + + + +dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}} +proc ::p::-1::InterfaceStacks {_ID_} { + upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP + return [dict get $MAP interfaces level0] +} + + +dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}} +proc ::p::-1::PatternStacks {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + return [dict get $MAP interfaces level1] +} + + +#!todo fix. need to account for references which were never set to a value +dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}} +proc ::p::-1::DeletePropertyReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + set refvars [info vars ::p::${OID}::_ref::*] + #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. + foreach rv $refvars { + foreach tinfo [trace info variable $rv] { + set ops {}; set cmd {} + lassign $tinfo ops cmd + trace remove variable $rv $ops $cmd + } + unset $rv + lappend cleared_references $rv + } + + + return [list deleted_property_references $cleared_references] +} + +dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}} +proc ::p::-1::DeleteMethodReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + + set iflist [dict get $MAP interfaces level0] + set iflist_reverse [lreferse $iflist] + #set iflist [dict get $MAP interfaces level0] + + + set refcommands [info commands ::p::${OID}::_ref::*] + foreach c $refcommands { + set reftail [namespace tail $c] + set field [lindex [split $c +] 0] + set field_is_a_method 0 + foreach IFID $iflist_reverse { + if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { + set field_is_a_method 1 + break + } + } + if {$field_is_a_method} { + #what if it's also a property? + interp alias {} $c {} + lappend cleared_references $c + } + } + + + return [list deleted_method_references $cleared_references] +} + + +dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}} +proc ::p::-1::DeleteReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method this + + set result [dict create] + dict set result {*}[$this .. DeletePropertyReferences] + dict set result {*}[$this .. DeleteMethodReferences] + + return $result +} + +## +#Digest +# +#!todo - review +# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!) +# +#!todo - write tests - check that digest changes when properties of contained objects change value +# +#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method? +# +dict set ::p::-1::_iface::o_methods Digest {arglist {args}} +proc ::p::-1::Digest {_ID_ args} { + set invocants [dict get $_ID_ i] + # md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway. + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] _OID alias default_method this + + + set interface_ids [dict get $MAP interfaces level0] + set IFID0 [lindex $interface_ids end] + + set known_flags {-recursive -algorithm -a -indent} + set defaults {-recursive 1 -algorithm md5 -indent ""} + if {[dict exists $args -a] && ![dict exists $args -algorithm]} { + dict set args -algorithm [dict get $args -a] + } + + set opts [dict merge $defaults $args] + foreach key [dict keys $opts] { + if {$key ni $known_flags} { + error "unknown option $key. Expected only: $known_flags" + } + } + + + set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256} + if {[dict get $opts -algorithm] ni $known_algos} { + error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos" + } + set algo [string tolower [dict get $opts -algorithm]] + + # append comma for each var so that all changes in adjacent vars detectable. + # i.e set x 34; set y 5 + # must be distinguishable from: + # set x 3; set y 45 + + if {[dict get $opts -indent] ne ""} { + set state "" + set indent "[dict get $opts -indent]" + } else { + set state "---\n" + set indent " " + } + append state "${indent}object_command: $this\n" + set indent "${indent} " + + #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state. + append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state. + + + + + #!todo - recurse into 'varspaces' + set varspaces_found [list] + append state "${indent}interfaces:\n" + foreach IID $interface_ids { + append state "${indent} - interface: $IID\n" + namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces + append state "${indent} varspaces:\n" + foreach vs $local_o_varspaces { + if {$vs ni $varspaces_found} { + lappend varspaces_found $vs + append state "${indent} - varspace: $vs\n" + } + } + } + + append state "${indent}vars:\n" + foreach var [info vars ::p::${OID}::*] { + append state "${indent} - [namespace tail $var] : \"" + if {[catch {append state "[set $var]"}]} { + append state "[array get $var]" + } + append state "\"\n" + } + + if {[dict get $opts -recursive]} { + append state "${indent}sub-objects:\n" + set subargs $args + dict set subargs -indent "$indent " + foreach obj [info commands ::p::${OID}::>*] { + append state "[$obj .. Digest {*}$subargs]\n" + } + + append state "${indent}sub-namespaces:\n" + set subargs $args + dict set subargs -indent "$indent " + foreach ns [namespace children ::p::${OID}] { + append state "${indent} - namespace: $ns\n" + foreach obj [info commands ${ns}::>*] { + append state "[$obj .. Digest {*}$subargs]\n" + } + } + } + + + if {$algo in {"" raw none}} { + return $state + } else { + if {$algo eq "md5"} { + package require md5 + return [::md5::md5 -hex $state] + } elseif {$algo eq "sha256"} { + package require sha256 + return [::sha2::sha256 -hex $state] + } elseif {$algo eq "blowfish"} { + package require patterncipher + patterncipher::>blowfish .. Create >b1 + set [>b1 . key .] 12341234 + >b1 . encrypt $state -final 1 + set result [>b1 . ciphertext] + >b1 .. Destroy + + } elseif {$algo eq "blowfish-binary"} { + + } else { + error "can't get here" + } + + } +} + + +dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}} +proc ::p::-1::Variable {_ID_ varname args} { + set invocants [dict get $_ID_ i] + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + #this interface itself is always a co-invocant + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set interfaces [dict get $MAP interfaces level0] + + #set existing_IID [lindex $map 1 0 end] + set existing_IID [lindex $interfaces end] + + set prev_openstate [set ::p::${existing_IID}::_iface::o_open] + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #IID changed + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + + #update original object command + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_openstate + } + + set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface) + + if {[llength $args]} { + #!assume var not already present on interface - it is an error to define twice (?) + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + + + #Implement if there is a default + #!todo - correct behaviour when overlaying on existing object with existing var of this name? + #if {[string length $varspace]} { + # set ::p::${OID}::${varspace}::$varname [lindex $args 0] + #} else { + set ::p::${OID}::$varname [lindex $args 0] + #} + } else { + #lappend ::p::${IID}::_iface::o_variables [list $varname] + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } + + #varspace '_iface' + + return +} + + +#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility + +dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}} +proc ::p::-1::PatternVariable {_ID_ varname args} { + set invocants [dict get $_ID_ i] + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + ##this interface itself is always a co-invocant + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top + + set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. + + + if {[llength $args]} { + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + } else { + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } + + return +} + +dict set ::p::-1::_iface::o_methods Varspaces {arglist args} +proc ::p::-1::Varspaces {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + if {![llength $args]} { + #query + set iid_top [lindex [dict get $MAP interfaces level0] end] + set iface ::p::ifaces::>$iid_top + if {![string length $iid_top]} { + error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " + } elseif {[$iface . isClosed]} { + error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " + } + return [set ::p::${iid_top}::_iface::o_varspaces] + } + set IID [::p::predator::get_possibly_new_open_interface $OID] + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + + set varspaces $args + foreach vs $varspaces { + if {[string length $vs] && ($vs ni $o_varspaces)} { + if {[string match ::* $vs} { + namespace eval $vs {} + } else { + namespace eval ::p::${OID}::$vs {} + } + lappend o_varspaces $vs + } + } + return $o_varspaces +} + +#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface +dict set ::p::-1::_iface::o_methods Varspace {arglist args} +# set the default varspace for the interface, so that new methods/properties refer to it. +# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. +proc ::p::-1::Varspace {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + if {![llength $args]} { + #query + set iid_top [lindex [dict get $MAP interfaces level0] end] + set iface ::p::ifaces::>$iid_top + if {![string length $iid_top]} { + error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " + } elseif {[$iface . isClosed]} { + error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " + } + return [set ::p::${iid_top}::_iface::o_varspace] + } + set varspace [lindex $args 0] + + #set interfaces [dict get $MAP interfaces level0] + #set iid_top [lindex $interfaces end] + + set IID [::p::predator::get_possibly_new_open_interface $OID] + + + #namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + + if {[string length $varspace]} { + #ensure namespace exists !? do after list test? + if {[string match ::* $varspace]} { + namespace eval $varspace {} + } else { + namespace eval ::p::${OID}::$varspace {} + } + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + set o_varspace $varspace +} + + +proc ::p::predator::get_possibly_new_open_interface {OID} { + #we need to re-upvar MAP rather than using a parameter - as we need to write back to it + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #puts stderr ">>>>creating new interface $iid_top" + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + + return $iid_top +} + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}} +# set the default varspace for the interface, so that new methods/properties refer to it. +# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. +proc ::p::-1::PatternVarspace {_ID_ varspace args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + if {[string length $varspace]} { + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + #o_varspace is the currently active varspace + set o_varspace $varspace + +} +################################################################################################################################################### + +#get varspace and default from highest interface - return all interface ids which define it +dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}} +proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + + array set propinfo {} + set found_property_names [list] + #start at the lowest and work up (normal storage order of $interfaces) + foreach iid $interfaces { + set propinfodict [set ::p::${iid}::_iface::o_properties] + set matching_propnames [dict keys $propinfodict $propnamepattern] + foreach propname $matching_propnames { + if {$propname ni $found_property_names} { + lappend found_property_names $propname + } + lappend propinfo($propname,interfaces) $iid + ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one + if {[dict exists $propinfodict $propname default]} { + set propinfo($propname,default) [dict get $propinfodict $propname default] + } + set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] + } + } + + set resultdict [dict create] + foreach propname $found_property_names { + set fields [list varspace $propinfo($propname,varspace)] + if {[array exists propinfo($propname,default)]} { + lappend fields default [set propinfo($propname,default)] + } + lappend fields interfaces $propinfo($propname,interfaces) + dict set resultdict $propname $fields + } + return $resultdict +} + + +dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args} +proc ::p::-1::GetTopPattern {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level1] + set iid_top [lindex $interfaces end] + if {![string length $iid_top]} { + lassign [dict get $MAP invocantdata] OID _alias _default_method object_command + error "No installed level1 interfaces (patterns) for object $object_command" + } + return ::p::ifaces::>$iid_top +} + + + +dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args} +proc ::p::-1::GetTopInterface {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set iid_top [lindex [dict get $MAP interfaces level0] end] + if {![string length $iid_top]} { + lassign [dict get $MAP invocantdata] OID _alias _default_method object_command + error "No installed level0 interfaces for object $object_command" + } + return ::p::ifaces::>$iid_top +} + + +dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} +proc ::p::-1::GetExpandableInterface {_ID_ args} { + +} + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods Property {arglist {property args}} +proc ::p::-1::Property {_ID_ property args} { + #puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args" + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + if {[llength $args] > 1} { + error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)" + } + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + + set prev_openstate [set ::p::${iid_top}::_iface::o_open] + + set iface ::p::ifaces::>$iid_top + + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + + namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + + + if {$headid == 1} { + #implementation + #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property + + #if {$o_varspace eq ""} { + # set ns ::p::${OID} + #} else { + # if {[string match "::*" $o_varspace]} { + # set ns $o_varspace + # } else { + # set ns ::p::${OID}::$o_varspace + # } + #} + #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]] + + proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]] + + + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property + proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] + + + #chainhead pointers + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 + + + } + + if {($property ni [dict keys $o_methods])} { + interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property + } + + + + #installation on object + + #namespace eval ::p::${OID} [list namespace export $property] + + + + #obsolete? + #if {$property ni [P $_ID_]} { + #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces + #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant + #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant + #} + + #link main (GET)/(SET) to this interface + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property + interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property + + #Only install property if no method of same name already installed here. + #(Method takes precedence over property because property always accessible via 'set' reference) + #convenience pointer to chainhead pointer. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } else { + #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed + + + } + + + set varspace [set ::p::${IID}::_iface::o_varspace] + + + + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} + dict set o_variables o_$property [list varspace $varspace] + + + + + if {[llength $args]} { + #should store default once only! + #set IFINFO(v,default,o_$property) $default + + set default [lindex $args end] + + dict set o_properties $property [list default $default varspace $varspace] + + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { + # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] + #} else { + # lappend o_properties [list $property $default] + #} + + if {$varspace eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${OID}::$o_varspace + } + } + + set ${ns}::o_$property $default + #set ::p::${OID}::o_$property $default + } else { + + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { + # set o_properties [lreplace $o_properties $posn $posn [list $property]] + #} else { + # lappend o_properties [list $property] + #} + dict set o_properties $property [list varspace $varspace] + + + #variable ::p::${OID}::o_$property + } + + + + + + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) + #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} + + set colProperties ::p::${OID}::_meta::>colProperties + if {[namespace which $colProperties] ne ""} { + if {![$colProperties . hasKey $property]} { + $colProperties . add [::p::internals::predator $_ID_ . $property .] $property + } + } + + return +} +################################################################################################################################################### + + + +################################################################################################################################################### + +################################################################################################################################################### +interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility +dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}} +proc ::p::-1::PatternProperty {_ID_ property args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + + + + if {$headid == 1} { + #implementation + #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property + proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]] + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property + proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] + + + #chainhead pointers + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 + + } + + if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} { + interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property + } + + set varspace [set ::p::${IID}::_iface::o_varspace] + + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} + dict set o_variables o_$property [list varspace $varspace] + + set argc [llength $args] + + if {$argc} { + if {$argc == 1} { + set default [lindex $args 0] + dict set o_properties $property [list default $default varspace $varspace] + } else { + #if more than one arg - treat as a dict of options. + if {[dict exists $args -default]} { + set default [dict get $args -default] + dict set o_properties $property [list default $default varspace $varspace] + } else { + #no default value + dict set o_properties $property [list varspace $varspace] + } + } + #! only set default for property... not underlying variable. + #lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]] + } else { + dict set o_properties $property [list varspace $varspace] + } + return +} +################################################################################################################################################### + + + + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}} +proc ::p::-1::PatternPropertyRead {_ID_ property args} { + set invocants [dict get $_ID_ i] + + set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' + set OID [lindex $this_invocant 0] + #set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias defaut_command cmd + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + if {$headid == 1} { + set headid 2 ;#reserve 1 for the getprop of the underlying property + } + + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ + + + #implement + #----------------------------------- + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + #implementation + if {![llength $idxlist]} { + proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body + } else { + #what are we trying to achieve here? .. + proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body + } + + + #----------------------------------- + + + #adjust chain-head pointer to point to new head. + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + return +} +################################################################################################################################################### + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}} +proc ::p::-1::PropertyRead {_ID_ property args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead) + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] + + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd] + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + if {$headid == 1} { + set headid 2 + } + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself) + + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body + + #----------------------------------- + + + + #pointer from prop-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } +} +################################################################################################################################################### + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}} +proc ::p::-1::PropertyWrite {_ID_ property argname body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. + + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + #pw short for propertywrite + #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] + + + set maxversion [::p::predator::method_chainhead $IID (SET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (SET)$property.$headid + + set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body + + #----------------------------------- + + + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid +} +################################################################################################################################################### + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}} +proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set existing_ifaces [lindex $map 1 1] + set posn [lsearch $existing_ifaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] + + #set ::p::${IID}::_iface::o_open 0 + } else { + } + + #pw short for propertywrite + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + + + + + return + +} +################################################################################################################################################### + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}} +proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers + #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #note $arraykeypattern actually contains the name of the argument + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern _dontcare_ ;# + } + proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body + + #----------------------------------- + + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid + +} +################################################################################################################################################### + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}} +proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #set ::p::${IID}::_iface::o_open 0 + } + + + upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + return +} +################################################################################################################################################### + + + +#lappend ::p::-1::_iface::o_methods Implements +#!todo - some way to force overriding of any abstract (empty) methods from the source object +#e.g leave interface open and raise an error when closing it if there are unoverridden methods? + + + + + +#implementation reuse - sugar for >object .. Clone >target +dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}} +proc ::p::-1::Extends {_ID_ pattern} { + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'Extends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Clone $object_command + +} +#implementation reuse - sugar for >pattern .. Create >target +dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}} +proc ::p::-1::PatternExtends {_ID_ pattern} { + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'PatternExtends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Create $object_command +} + + +dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}} +proc ::p::-1::Extend {_ID_ {idx ""}} { + puts stderr "Extend is DEPRECATED - use Expand instead" + tailcall ::p::-1::Expand $_ID_ $idx +} + +#set the topmost interface on the iStack to be 'open' +dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}} +proc ::p::-1::Expand {_ID_ {idx ""}} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set iid_top [lindex $interfaces end] + set iface ::p::ifaces::>$iid_top + + if {![string length $iid_top]} { + #no existing interface - create a new one + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [list $iid_top] + dict set MAP interfaces $extracted_sub_dict ;#write new interface into map + $iface . open + return $iid_top + } else { + if {[$iface . isOpen]} { + #already open.. + #assume ready to expand.. shared or not! + return $iid_top + } + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {[$iface . refCount] > 1} { + if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} { + #!warning! not exercised by test suites! + + #remove ourself from the usedby list of the previous interface + array unset ::p::${iid_top}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + #remove existing interface & add + set posn [lsearch $interfaces $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + + set iid_top $IID + set iface ::p::ifaces::>$iid_top + } + } + } + + $iface . open + return $iid_top +} + +dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}} +proc ::p::-1::PatternExtend {_ID_ {idx ""}} { + puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead" + tailcall ::p::-1::PatternExpand $_ID_ $idx +} + + + +#set the topmost interface on the pStack to be 'open' if it's not shared +# if shared - 'copylink' to new interface before opening for extension +dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}} +proc ::p::-1::PatternExpand {_ID_ {idx ""}} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + #puts stderr "no tests written for PatternExpand " + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces + set iid_top [lindex $ifaces end] + set iface ::p::ifaces::>$iid_top + + if {![string length $iid_top]} { + #no existing interface - create a new one + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [list $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [list $iid_top] + $iface . open + return $iid_top + } else { + if {[$iface . isOpen]} { + #already open.. + #assume ready to expand.. shared or not! + return $iid_top + } + + if {[$iface . refCount] > 1} { + if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} { + #!WARNING! not exercised by test suite! + #remove ourself from the usedby list of the previous interface + array unset ::p::${iid_top}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $ifaces $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID] + + set iid_top $IID + set iface ::p::ifaces::>$iid_top + } + } + } + + $iface . open + return $iid_top +} + + + + + +dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}} +proc ::p::-1::Properties {_ID_ {idx ""}} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set col ::p::${OID}::_meta::>colProperties + + if {[namespace which $col] eq ""} { + patternlib::>collection .. Create $col + foreach IID $ifaces { + dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] { + if {![$col . hasIndex $prop]} { + $col . add [::p::internals::predator $_ID_ . $prop .] $prop + } + } + } + } + + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } +} + +dict set ::p::-1::_iface::o_methods P {arglist {}} +proc ::p::-1::P {_ID_} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set members [list] + foreach IID $interfaces { + foreach prop [dict keys [set ::p::${IID}::_iface::o_properties]] { + lappend members $prop + } + } + return [lsort $members] + +} +#Interface Properties +dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}} +proc ::p::-1::IP {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set members [list] + + foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { + if {[string match $glob [lindex $m 0]]} { + lappend members [lindex $m 0] + } + } + return $members +} + + +#used by rename.test - theoretically should be on a separate interface! +dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}} +proc ::p::-1::CheckInvocants {_ID_ args} { + #check all invocants in the _ID_ are consistent with data stored in their MAP variable + set status "ok" ;#default to optimistic assumption + set problems [list] + + set invocant_dict [dict get $_ID_ i] + set invocant_roles [dict keys $invocant_dict] + + foreach role $invocant_roles { + set invocant_list [dict get $invocant_dict $role] + foreach aliased_invocantdata $invocant_list { + set OID [lindex $aliased_invocantdata 0] + set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] + #we use lrange to make sure the lists are in canonical form + if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { + set status "not-ok" + lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] + } + } + + } + + + set result [dict create] + dict set result status $status + dict set result problems $problems + + return $result +} + + +#get or set t +dict set ::p::-1::_iface::o_methods Namespace {arglist {args}} +proc ::p::-1::Namespace {_ID_ args} { + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set IID [lindex [dict get $MAP interfaces level0] end] + + namespace upvar ::p::${IID}::_iface o_varspace active_varspace + + if {[string length $active_varspace]} { + set ns ::p::${OID}::$active_varspace + } else { + set ns ::p::${OID} + } + + #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object? + # - should .. Namespace be usable at all from outside the object? + + + if {[llength $args]} { + #special case some of the namespace subcommands. + + #delete + if {[string match "d*" [lindex $args 0]]} { + error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object." + } + #upvar,ensemble,which,code,origin,expor,import,forget + if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} { + return [namespace eval $ns [list namespace {*}$args]] + } + #current + if {[string match "cu*" [lindex $args 0]]} { + return $ns + } + + #children,eval,exists,inscope,parent,qualifiers,tail + return [namespace {*}[linsert $args 1 $ns]] + } else { + return $ns + } +} + + + + + + + + + + +dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}} +proc ::p::-1::PatternUnknown {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + #::p::predator::remap $invocant + } + + set handlermethod [lindex $args 0] + + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } + +} + + + +dict set ::p::-1::_iface::o_methods Unknown {arglist {args}} +proc ::p::-1::Unknown {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + set prev_open [set ::p::${existing_IID}::_iface::o_open] + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_open + } + + set handlermethod [lindex $args 0] + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + #set ::p::${IID}::(unknown) $handlermethod + + + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod + interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod + + #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod] + #namespace eval ::p::${OID} [list namespace unknown $handlermethod] + + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } + +} + + +#useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []' +# should also work for non-object results +dict set ::p::-1::_iface::o_methods As {arglist {varname}} +proc ::p::-1::As {_ID_ varname} { + set invocants [dict get $_ID_ i] + #puts stdout "invocants: $invocants" + #!todo - handle multiple invocants with other roles, not just 'this' + + set OID [lindex [dict get $_ID_ i this] 0 0] + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + tailcall set $varname $cmd + } else { + #puts stdout "info level 1 [info level 1]" + set role_members [dict get $_ID_ i this] + if {[llength $role_members] == 1} { + set member [lindex $role_members 0] + lassign $member _OID namespace default_method stackvalue _wrapped + tailcall set $varname $stackvalue + } else { + #multiple invocants - return all results as a list + set resultlist [list] + foreach member $role_members { + lassign $member _OID namespace default_method stackvalue _wrapped + lappend resultlist $stackvalue + } + tailcall set $varname $resultlist + } + } +} + +#!todo - AsFileStream ?? +dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}} +proc ::p::-1::AsFile {_ID_ filename args} { + dict set default -force 0 + dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object + set opts [dict merge $default $args] + set force [dict get $opts -force] + set dumpmethod [dict get $opts -dumpmethod] + + + if {[file pathtype $filename] eq "relative"} { + set filename [pwd]/$filename + } + set filedir [file dirname $filename] + if {![sf::file_writable $filedir]} { + error "(method AsFile) ERROR folder $filedir is not writable" + } + if {[file exists $filename]} { + if {!$force} { + error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite" + } + if {![sf::file_writable $filename]} { + error "(method AsFile) ERROR file $filename is not writable - check permissions" + } + } + set fd [open $filename w] + fconfigure $fd -translation binary + + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + #tailcall set $varname $cmd + set object_data [$cmd {*}$dumpmethod] + puts -nonewline $fd $object_data + close $fd + return [list status 1 bytes [string length $object_data] filename $filename] + } else { + #puts stdout "info level 1 [info level 1]" + set role_members [dict get $_ID_ i this] + if {[llength $role_members] == 1} { + set member [lindex $role_members 0] + lassign $member _OID namespace default_method stackvalue _wrapped + puts -nonewline $fd $stackvalue + close $fd + #tailcall set $varname $stackvalue + return [list status 1 bytes [string length $stackvalue] filename $filename] + } else { + #multiple invocants - return all results as a list + set resultlist [list] + foreach member $role_members { + lassign $member _OID namespace default_method stackvalue _wrapped + lappend resultlist $stackvalue + } + puts -nonewline $fd $resultset + close $fd + return [list status 1 bytes [string length $resultset] filename $filename] + #tailcall set $varname $resultlist + } + } + +} + + + +dict set ::p::-1::_iface::o_methods Object {arglist {}} +proc ::p::-1::Object {_ID_} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + set result [string map [list ::> ::] $cmd] + if {![catch {info level -1} prev_level]} { + set called_by "(called by: $prev_level)" + } else { + set called_by "(called by: interp?)" + + } + + puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" + puts stdout " (returning $result)" + + return $result +} + +#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname +dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} +proc ::p::-1::MakeAlias {_ID_cmdname } { + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + error "concept probably won't work - try making dispatcher understand trailing '= cmdname' " +} +dict set ::p::-1::_iface::o_methods ID {arglist {}} +proc ::p::-1::ID {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + return $OID +} + +dict set ::p::-1::_iface::o_methods IFINFO {arglist {}} +proc ::p::-1::IFINFO {_ID_} { + puts stderr "--_ID_: $_ID_--" + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + + puts stderr "-- MAP: $MAP--" + + set interfaces [dict get $MAP interfaces level0] + set IFID [lindex $interfaces 0] + + if {![llength $interfaces]} { + puts stderr "No interfaces present at level 0" + } else { + foreach IFID $interfaces { + set iface ::p::ifaces::>$IFID + puts stderr "$iface : [$iface --]" + puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" + set variables [set ::p::${IFID}::_iface::o_variables] + puts stderr "\tvariables: $variables" + } + } + +} + + + + +dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} +proc ::p::-1::INVOCANTDATA {_ID_} { + #same as a call to: >object .. + return $_ID_ +} + +#obsolete? +dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}} +proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} { + set updated_ID_ $_ID_ + array set updated_roles [list] + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + foreach role $invocant_roles { + + set role_members [dict get $invocants $role] + foreach member [dict get $invocants $role] { + #each member is a 2-element list consisting of the OID and a dictionary + #each member is a 5-element list + #set OID [lindex $member 0] + #set object_dict [lindex $member 1] + lassign $member OID alias itemcmd cmd wrapped + + set MAP [set ::p::${OID}::_meta::map] + #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} + + if {[dict get $MAP invocantdata] eq $member} + #same - nothing to do + + } else { + package require overtype + puts stderr "---------------------------------------------------------" + puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" + set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] + puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" + puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" + puts stderr "---------------------------------------------------------" + #take _meta::map version + lappend updated_roles($role) [dict get $MAP invocantdata] + } + + } + + #overwrite changed roles only + foreach role [array names updated_roles] { + dict set updated_ID_ i $role [set updated_roles($role)] + } + + return $updated_ID_ +} + + + +dict set ::p::-1::_iface::o_methods INFO {arglist {}} +proc ::p::-1::INFO {_ID_} { + set result "" + append result "_ID_: $_ID_\n" + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + append result "invocant roles: $invocant_roles\n" + set total_invocants 0 + foreach key $invocant_roles { + incr total_invocants [llength [dict get $invocants $key]] + } + + append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" + foreach key $invocant_roles { + append result "\t-------------------------------\n" + append result "\trole: $key\n" + set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants + append result "\t Raw data for this role: $role_members\n" + append result "\t Number of invocants in this role: [llength $role_members]\n" + foreach member $role_members { + #set OID [lindex [dict get $invocants $key] 0 0] + set OID [lindex $member 0] + append result "\t\tOID: $OID\n" + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + append result "\t\tmap:\n" + foreach key [dict keys $MAP] { + append result "\t\t\t$key\n" + append result "\t\t\t\t [dict get $MAP $key]\n" + append result "\t\t\t----\n" + } + lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped + append result "\t\tNamespace: $namespace\n" + append result "\t\tDefault method: $default_method\n" + append result "\t\tCommand: $cmd\n" + append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n" + append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n" + append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n" + } else { + lassign $member _OID namespace default_method stackvalue _wrapped + append result "\t\t last item on the predator stack is a value not an object" + append result "\t\t Value is: $stackvalue" + + } + } + append result "\n" + append result "\t-------------------------------\n" + } + + + + return $result +} + + + + +dict set ::p::-1::_iface::o_methods Rename {arglist {args}} +proc ::p::-1::Rename {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + if {![llength $args]} { + error "Rename expected \$newname argument" + } + + #Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant? + upvar #0 ::p::${OID}::_meta::map MAP + + + + #puts ">>.>> Rename. _ID_: $_ID_" + + if {[catch { + + if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { + + #appears to be a 'trace command rename' firing + #puts "\t>>>> rename trace fired $MAP $args <<<" + + lassign $args oldcmd newcmd + set extracted_invocantdata [dict get $MAP invocantdata] + lset extracted_invocantdata 3 $newcmd + dict set MAP invocantdata $extracted_invocantdata + + + lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped + + #Write the same info into the _ID_ value of the alias + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] + + + + #! $object_command was initially created as the renamed alias - so we have to do it again + uplevel 1 [list rename $alias $object_command] + trace add command $object_command rename [list $object_command .. Rename] + + } elseif {[llength $args] == 1} { + #let the rename trace fire and we will be called again to do the remap! + uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] + } else { + error "Rename expected \$newname argument ." + } + + } errM]} { + puts stderr "\t@@@@@@ rename error" + set ruler "\t[string repeat - 80]" + puts stderr $ruler + puts stderr $errM + puts stderr $ruler + + } + + return + + +} + +proc ::p::obj_get_invocants {_ID_} { + return [dict get $_ID_ i] +} +#The invocant role 'this' is special and should always have only one member. +# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX +proc ::p::obj_get_this_oid {_ID_} { + return [lindex [dict get $_ID_ i this] 0 0] +} +proc ::p::obj_get_this_ns {_ID_} { + return [lindex [dict get $_ID_ i this] 0 1] +} + +proc ::p::obj_get_this_cmd {_ID_} { + return [lindex [dict get $_ID_ i this] 0 3] +} +proc ::p::obj_get_this_data {_ID_} { + lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd + #set this_invocant_data {*}[dict get $_ID_ i this] + return [list oid $OID ns $ns cmd $cmd] +} +proc ::p::map {OID varname} { + tailcall upvar #0 ::p::${OID}::_meta::map $varname +} + + + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.0.tm deleted file mode 100644 index fd6b00ec..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.0.tm +++ /dev/null @@ -1,705 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2024 -# -# @@ Meta Begin -# Application modpod 0.1.0 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.0] -#[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require modpod] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of modpod -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by modpod -#[list_begin itemized] - -package require Tcl 8.6- -package require struct::set ;#review -package require punk::lib -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::class { - #*** !doctools - #[subsection {Namespace modpod::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod { - namespace export {[a-z]*}; # Convention: export all lowercase - - variable connected - if {![info exists connected(to)]} { - set connected(to) list - } - variable modpodscript - set modpodscript [info script] - if {[string tolower [file extension $modpodscript]] eq ".tcl"} { - set connected(self) [file dirname $modpodscript] - } else { - #expecting a .tm - set connected(self) $modpodscript - } - variable loadables [info sharedlibextension] - variable sourceables {.tcl .tk} ;# .tm ? - - #*** !doctools - #[subsection {Namespace modpod}] - #[para] Core API functions for modpod - #[list_begin definitions] - - - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - proc connect {args} { - puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { - -type -default "" - *values -min 1 -max 1 - path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" - } $args] - catch { - punk::lib::showdict $argd ;#heavy dependencies - } - set opt_path [dict get $argd values path] - variable connected - set original_connectpath $opt_path - set modpodpath [modpod::system::normalize $opt_path] ;# - - if {$modpodpath in $connected(to)} { - return [dict create ok ALREADY_CONNECTED] - } - lappend connected(to) $modpodpath - - set connected(connectpath,$opt_path) $original_connectpath - set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info_script]]}] - - set connected(location,$modpodpath) [file dirname $modpodpath] - set connected(startdata,$modpodpath) -1 - set connected(type,$modpodpath) [dict get $argd-opts -type] - set connected(fh,$modpodpath) "" - - if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { - set connected(type,$modpodpath) "unwrapped" - lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] - - } else { - #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname $modpodpath] - if {$connected(type,$modpodpath) ne "unwrapped"} { - #Not directly connected to unwrapped version - but may still be redirected there - set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] - if {[file exists $unwrappedFolder]} { - #folder with exact version-match must exist for redirect to 'unwrapped' - set con(type,$modpodpath) "modpod-redirecting" - } - } - - } - set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" - set connected(tmfile,$modpodpath) - set tail_segments [list] - set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] - break - } - } - if {[llength $tail_segments]} { - set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require - } else { - set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] - } - - switch -exact -- $connected(type,$modpodpath) { - "modpod-redirecting" { - #redirect to the unwrapped version - set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] - - } - "unwrapped" { - if {[info commands ::thread::id] ne ""} { - set from [pid],[thread::id] - } else { - set from [pid] - } - #::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" - return [list ok ""] - } - default { - #autodetect .tm - zip/tar ? - #todo - use vfs ? - - #connect to tarball - start at 1st header - set connected(startdata,$modpodpath) 0 - set fh [open $modpodpath r] - set connected(fh,$modpodpath) $fh - fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} - - if {$connected(startdata,$modpodpath) >= 0} { - #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { - seek $fh $connected(startdata,$modpodpath) start - return [list ok $fh] - } else { - #error "cannot verify tar header" - } - } - lpop connected(to) end - set connected(startdata,$modpodpath) -1 - unset connected(fh,$modpodpath) - catch {close $fh} - return [dict create err {Does not appear to be a valid modpod}] - } - } - } - proc disconnect {{modpod ""}} { - variable connected - if {![llength $connected(to)]} { - return 0 - } - if {$modpod eq ""} { - puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" - set modpod [lindex $connected(to) end] - } - - if {[set posn [lsearch $connected(to) $modpod]] == -1} { - puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" - return 0 - } - if {[string length $connected(fh,$modpod)]} { - close $connected(fh,$modpod) - } - array unset connected *,$modpod - set connected(to) [lreplace $connected(to) $posn $posn] - return 1 - } - proc get {args} { - set argd [punk::args::get_dict { - -from -default "" -help "path to pod" - *values -min 1 -max 1 - filename - } $args] - set frompod [dict get $argd opts -from] - set filename [dict get $argd values filename] - - variable connected - set modpod [::tarjar::system::connect_if_not $frompod] - set fh $connected(fh,$modpod) - if {$connected(type,$modpod) eq "unwrapped"} { - #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder - if {[string range $filename 0 0 eq "/"]} { - #absolute path (?) - set path [file join $connected(location,$modpod) .. [string trim $filename /]] - } else { - #relative path - use #modpod-xxx as base - set path [file join $connected(location,$modpod) $filename] - } - set fd [open $path r] - #utf-8? - #fconfigure $fd -encoding iso8859-1 -translation binary - return [list ok [lindex [list [read $fd] [close $fd]] 0]] - } else { - #read from vfs - puts stderr "get $filename from wrapped pod '$frompod' not implemented" - } - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::lib { - namespace export {[a-z]*}; # Convention: export all lowercase - namespace path [namespace parent] - #*** !doctools - #[subsection {Namespace modpod::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - proc is_valid_tm_version {versionpart} { - #Needs to be suitable for use with Tcl's 'package vcompare' - if {![catch [list package vcompare $versionparts $versionparts]]} { - return 1 - } else { - return 0 - } - } - proc make_zip_modpod {zipfile outfile} { - set mount_stub { - #zip file with Tcl loader prepended. - #generated using modpod::make_zip_modpod - if {[catch {file normalize [info script]} modfile]} { - error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" - } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #determine module namespace so we can mount appropriately - proc intersect {A B} { - if {[llength $A] == 0} {return {}} - if {[llength $B] == 0} {return {}} - if {[llength $B] > [llength $A]} { - set res $A - set A $B - set B $res - } - set res {} - foreach x $A {set ($x) {}} - foreach x $B { - if {[info exists ($x)]} { - lappend res $x - } - } - return $res - } - set lcase_tmfile_segments [string tolower [file split $moddir]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use propertly cased tail - break - } - } - if {[llength $tail_segments]} { - set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require - set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver - } else { - set fullpackage $moduletail - set mount_at #modpod/#mounted-modpod-$mod_and_ver - } - - if {[info commands tcl::zipfs::mount] ne ""} { - #argument order changed to be consistent with vfs::zip::Mount etc - #early versions: zipfs::Mount mountpoint zipname - #since 2023-09: zipfs::Mount zipname mountpoint - #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) - #This is presumably related to // being interpreted as a network path - set mountpoints [dict keys [tcl::zipfs::mount]] - if {"//zipfs:/$mount_at" ni $mountpoints} { - #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it - if {[catch { - #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) - #puts "tcl::zipfs::mount $modfile $mount_at" - tcl::zipfs::mount $modfile $mount_at - } errM]} { - #try old api - if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { - puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" - puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" - } - } - if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" - #tcl::zipfs::unmount //zipfs:/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form - source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #fallback to slower vfs::zip - #NB. We don't create the intermediate dirs - but the mount still works - if {![file exists $moddir/$mount_at]} { - if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver" - append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." - append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" - error $msg - } else { - set fd [vfs::zip::Mount $modfile $moddir/$mount_at] - if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - } - source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } - } - #zipped data follows - } - #todo - test if zipfile has #modpod-loadcript.tcl before even creating - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub - - } - proc make_zip_modpod1 {zipfile outfile} { - set mount_stub { - #zip file with Tcl loader prepended. - #generated using modpod::make_zip_modpod - if {[catch {file normalize [info script]} modfile]} { - error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" - } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - if {![file exists $moddir/#mounted-modpod-$mod_and_ver]} { - if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver" - append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." - append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $ - } - set fd [vfs::zip::Mount $modfile $moddir/#mounted-modpod-$mod_and_ver] - if {![file exists $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/#mounted-modpod-$mod_and_ver - error "Unable to find #modpod-$mod_and_ver/$mod_and_ver.tm in $modfile" - } - } - source $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm - } - #zipped data follows - } - #todo - test if zipfile has #modpod-loadcript.tcl before even creating - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub - - } - proc make_zip_source_mountable {zipfile outfile} { - set mount_stub { - package require vfs::zip - vfs::zip::Mount [info script] [info script] - } - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -namespace eval modpod::system { - #*** !doctools - #[subsection {Namespace modpod::system}] - #[para] Internal functions that are not part of the API - - #deflate,store only supported - proc make_mountable_zip {zipfile outfile mount_stub} { - set in [open $zipfile r] - fconfigure $in -encoding iso8859-1 -translation binary - set out [open $outfile w+] - fconfigure $out -encoding iso8859-1 -translation binary - puts -nonewline $out $mount_stub - set offset [tell $out] - lappend report "sfx stub size: $offset" - fcopy $in $out - - close $in - set size [tell $out] - #Now seek in $out to find the end of directory signature: - #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text - if {$size < 65559} { - set seek 0 - } else { - set seek [expr {$size - 65559}] - } - seek $out $seek - set data [read $out] - set start_of_end [string last "\x50\x4b\x05\x06" $data] - #set start_of_end [expr {$start_of_end + $seek}] - incr start_of_end $seek - - lappend report "START-OF-END: $start_of_end ([expr {$start_of_end - $size}]) [string length $data]" - - seek $out $start_of_end - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - lappend report "End of central directory: [array get eocd]" - seek $out [expr {$start_of_end+16}] - - #adjust offset of start of central directory by the length of our sfx stub - puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $offset}]] - flush $out - - seek $out $start_of_end - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - # 0x06054b50 - end of central dir signature - puts stderr "$end_of_ctrl_dir" - puts stderr "comment_len: $eocd(comment_len)" - puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" - lappend report "New dir offset: $eocd(diroffset)" - lappend report "Adjusting $eocd(totalnum) zip file items." - catch { - punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies - } - - seek $out $eocd(diroffset) - for {set i 0} {$i <$eocd(totalnum)} {incr i} { - set current_file [tell $out] - set fileheader [read $out 46] - puts -------------- - puts [ansistring VIEW -lf 1 $fileheader] - puts -------------- - #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - - binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - set ::last_header $fileheader - - puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" - puts "ver: $x(version)" - puts "method: $x(method)" - - #33639248 dec = 0x02014b50 - central file header signature - if { $x(sig) != 33639248 } { - error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" - } - - foreach size $x(lengths) var {filename extrafield comment} { - if { $size > 0 } { - set x($var) [read $out $size] - } else { - set x($var) "" - } - } - set next_file [tell $out] - lappend report "file $i: $x(offset) $x(sizes) $x(filename)" - - seek $out [expr {$current_file+42}] - puts -nonewline $out [binary format i [expr {$x(offset)+$offset}]] - - #verify: - flush $out - seek $out $current_file - set fileheader [read $out 46] - lappend report "old $x(offset) + $offset" - binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - lappend report "new $x(offset)" - - seek $out $next_file - } - close $out - #pdict/showdict reuire punk & textlib - ie lots of dependencies - #don't fall over just because of that - catch { - punk::lib::showdict -roottype list -chan stderr $report - } - #puts [join $report \n] - return - } - - proc connect_if_not {{podpath ""}} { - upvar ::modpod::connected connected - set podpath [::modpod::system::normalize $podpath] - set docon 0 - if {![llength $connected(to)]} { - if {![string length $podpath]} { - error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" - } else { - set docon 1 - } - } else { - if {![string length $podpath]} { - set podpath [lindex $connected(to) end] - puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" - } else { - if {$podpath ni $connected(to)} { - set docon 1 - } - } - } - if {$docon} { - if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { - error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" - } else { - return $podpath - } - } - #we were already connected - return $podpath - } - - proc myversion {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" - } - set fname [file tail [file rootname [file normalize $script]]] - set scriptdir [file dirname $script] - - if {![string match "#modpod-*" $fname]} { - lassign [lrange [split $fname -] end-1 end] _pkgname version - } else { - lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version - if {![string length $version]} { - #try again on the name of the containing folder - lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version - #todo - proper walk up the directory tree - if {![string length $version]} { - #try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) - lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version - } - } - } - - #tarjar::Log debug "'myversion' determined version for [info script]: $version" - return $version - } - - proc myname {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" - } - return $connected(fullpackage,$script) - } - proc myfullname {} { - upvar ::modpod::connected connected - set script [info script] - #set script [::tarjar::normalize $script] - set script [file normalize $script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" - } - return $::tarjar::connected(fullpackage,$script) - } - proc normalize {path} { - #newer versions of Tcl don't do tilde sub - - #Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) - # we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. - set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. - set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after - set path [file normalize $path] - #set path [string tolower $path] ;#must do this after file normalize - return [string map [list $matilda ~] $path] ;#get our tildes back. -} -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide modpod [namespace eval modpod { - variable pkg modpod - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/natsort-0.1.1.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/natsort-0.1.1.5.tm deleted file mode 100644 index 0e4260b8..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/natsort-0.1.1.5.tm +++ /dev/null @@ -1,1894 +0,0 @@ -#! /usr/bin/env tclsh - - -package require flagfilter -namespace import ::flagfilter::check_flags - -namespace eval natsort { - proc scriptdir {} { - set possibly_linked_script [file dirname [file normalize [file join [info script] ...]]] - if {[file isdirectory $possibly_linked_script]} { - return $possibly_linked_script - } else { - return [file dirname $possibly_linked_script] - } - } - tcl::tm::add [scriptdir] -} - - -namespace eval natsort { - variable stacktrace_on 0 - - proc do_error {msg {then error}} { - #note we exit or error out even if debug selected - as every do_error call is meant to interrupt code processing at the site of call - #this is not just a 'logging' call even though it has log-like descriptors - lassign $then type code - if {$code eq ""} { - set code 1 - } - set type [string tolower $type] - set levels [list debug info notice warn error critical] - if {$type in [concat $levels exit]} { - puts stderr "|$type> $msg" - } else { - puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be one of '$levels' or 'exit '" - } - if {$::tcl_interactive} { - #may not always be desirable - but assumed to be more useful not to exit despite request, to aid in debugging - if {[string tolower $type] eq "exit"} { - puts stderr " (exit suppressed due to tcl_interactive - raising error instead)" - if {![string is digit -strict $code]} { - puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be: 'exit '" - } - } - return -code error $msg - } else { - if {$type ne "exit"} { - return -code error $msg - } else { - if {[string is digit -strict $code]} { - exit $code - } else { - puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be 'error' or 'exit '" - return -code error $msg - } - } - } - } - - - - - - - variable debug 0 - variable testlist - set testlist { - 00.test-firstposition.txt - 0001.blah.txt - 1.test-sorts-after-all-leadingzero-number-one-equivs.txt - 1010.thousand-and-ten.second.txt - 01010.thousand-and-ten.first.txt - 0001.aaa.txt - 001.zzz.txt - 08.octal.txt-last-octal - 008.another-octal-first-octal.txt - 08.again-second-octal.txt - 001.a.txt - 0010.reconfig.txt - 010.etc.txt - 005.etc.01.txt - 005.Etc.02.txt - 005.123.abc.txt - 200.somewhere.txt - 2zzzz.before-somewhere.txt - 00222-after-somewhere.txt - 005.00010.abc.txt - 005.a3423bc.00010.abc.txt - 005.001.abc.txt - 005.etc.1010.txt - 005.etc.010.txt - 005.etc.10.txt - " 005.etc.10.txt" - 005.etc.001.txt - 20.somewhere.txt - 4611686018427387904999999999-bignum.txt - 4611686018427387903-bigishnum.txt - 9223372036854775807-bigint.txt - etca-a - etc-a - etc2-a - a0001blah.txt - a010.txt - winlike-sort-difference-0.1.txt - winlike-sort-difference-0.1.1.txt - a1.txt - b1-a0001blah.txt - b1-a010.txt - b1-a1.txt - -a1.txt - --a1.txt - --a10.txt - 2.high-two.yml - 02.higher-two.yml - reconfig.txt - _common.stuff.txt - CASETEST.txt - casetest.txt - something.txt - some~thing.txt - someathing.txt - someThing.txt - thing.txt - thing_revised.txt - thing-revised.txt - "thing revised.txt" - "spacetest.txt" - " spacetest.txt" - " spacetest.txt" - "spacetest2.txt" - "spacetest 2.txt" - "spacetest02.txt" - name.txt - name2.txt - "name .txt" - "name2 .txt" - blah.txt - combined.txt - a001.txt - .test - .ssh - "Feb 10.txt" - "Feb 8.txt" - 1ab23v23v3r89ad8a8a8a9d.txt - "Folder (10)/file.tar.gz" - "Folder/file.tar.gz" - "Folder (1)/file (1).tar.gz" - "Folder (1)/file.tar.gz" - "Folder (01)/file.tar.gz" - "Folder1/file.tar.gz" - "Folder(1)/file.tar.gz" - - } - lappend testlist "Some file.txt" - lappend testlist " Some extra file1.txt" - lappend testlist " Some extra file01.txt" - lappend testlist " some extra file1.txt" - lappend testlist " Some extra file003.txt" - lappend testlist " Some file.txt" - lappend testlist "Some extra file02.txt" - lappend testlist "Program Files (x86)" - lappend testlist "01999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999991-bigger-pathologically-bignum.txt" - lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt" - lappend testlist "29999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-smaller-pathologically-bignum.txt" - lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 1.txt" - lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 01.txt" - lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt" - lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a01a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt" - lappend testlist "b1b1b1b1.txt" - lappend testlist "b1b01z1z1.txt" - lappend testlist "c1c111c1.txt" - lappend testlist "c1c1c1c1.txt" - - namespace eval overtype { - proc right {args} { - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set olen [string length $overtext] - set ulen [string length $undertext] - - if {$opt(-overflow)} { - return [string range $undertext 0 end-$olen]$overtext - } else { - if {$olen > $ulen} { - set diff [expr {$olen - $ulen}] - return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] - } else { - return [string range $undertext 0 end-$olen]$overtext - } - } - } - proc left {args} { - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-ellipsis) 0 - set opt(-ellipsistext) {...} - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set len [string length $undertext] - set overlen [string length $overtext] - set diff [expr {$overlen - $len}] - - #puts stdout "====================>overtype: datalen:$len overlen:$overlen diff:$diff" - #puts stdout "====================>overtype: data: $overtext" - if {$diff > 0} { - if {$opt(-overflow)} { - return $overtext - } else { - if {$opt(-ellipsis)} { - return [overtype::left [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] - } else { - return [string range $overtext 0 [expr {$len -1}]] - } - } - } else { - return "$overtext[string range $undertext $overlen end]" - } - } - - } - - #considered using hex to make large numbers more compact for viewing in debug output - but it's not that much shorter and probably obscures more than it helps. - proc hex2dec {largeHex} { - #todo - use punk::lib::hex2dec - (scan supports ll so can do larger hex values directly) - set res 0 - set largeHex [string map [list _ ""] $largeHex] - if {[string length $largeHex] <=7} { - #scan can process up to FFFFFFF and does so quickly - return [scan $largeHex %x] - } - foreach hexDigit [split $largeHex {}] { - set new 0x$hexDigit - set res [expr {16*$res + $new}] - } - return $res - } - proc dec2hex {decimalNumber} { - format %4.4llX $decimalNumber - } - - #punk::lib::trimzero - proc trimzero {number} { - set trimmed [string trimleft $number 0] - if {[string length $trimmed] == 0} { - set trimmed 0 - } - return $trimmed - } - #todo - consider human numeric split - #e.g consider SI suffixes k|KMGTPEZY in that order - - #in this context, for natural sorting - numeric segments don't contain underscores or other punctuation such as . - + etc. - #review - what about unicode equivalents such as wide numerals \UFF10 to \UFF19? unicode normalization? - proc split_numeric_segments {name} { - set segments [list] - while {[string length $name]} { - if {[scan $name {%[0-9]%n} chunk len] == 2} { - lappend segments $chunk - set name [string range $name $len end] - } - if {[scan $name {%[^0-9]%n} chunk len] == 2} { - lappend segments $chunk - set name [string range $name $len end] - } - } - return $segments - } - - proc padleft {str count {ch " "}} { - set val [string repeat $ch $count] - append val $str - set diff [expr {max(0,$count - [string length $str])}] - set offset [expr {max(0,$count - $diff)}] - set val [string range $val $offset end] - } - - - # Sqlite may have limited collation sequences available in default builds. - # with custom builds - there may be others such as 'natsort' - see https://sqlite.org/forum/forumpost/e4dc6f3331 - # This is of limited use with the few builtin collations available in 2023 ie binary,nocase & rtrim - # but may provide a quicker,flexible sort option, especially if/when more collation sequences are added to sqlite - # There are also prebuilt packages such as sqlite3-icu which allows things like "SELECT icu_load_collation('en_AU', 'australian');" - proc sort_sqlite {stringlist args} { - package require sqlite3 - - - set args [check_flags -caller natsort_sqlite -defaults [list -db :memory: -collate nocase -winlike 0 -topchars "\uFFFF" -debug 0 -splitchars [list / . - _] -extras {all}] -values $args] - set db [string trim [dict get $args -db]] - set collate [string trim [dict get $args -collate]] - set debug [string trim [dict get $args -debug]] - set topchars [string trim [dict get $args -topchars]] - - set topdot [expr {"." in $topchars}] - set topunderscore [expr {"_" in $topchars}] - - - sqlite3 db_sort_basic $db - set orderedlist [list] - db_sort_basic eval [string map [list %collate% $collate] {create table sqlitesort(index0 text COLLATE %collate%, name text COLLATE %collate%)}] - foreach nm $stringlist { - set segments [split_numeric_segments $nm] - set index "" - set s 0 - foreach seg $segments { - if {($s == 0) && ![string length [string trim $seg]]} { - #don't index leading space - } elseif {($s == 0) && ($topunderscore) && [string match _* [string trim $seg]]} { - append index "[padleft "0" 5]-d -100 topunderscore " - append index [string trim $seg] - } elseif {($s == 0) && ($topdot) && [string match .* [string trim $seg]]} { - append index "[padleft "0" 5]-d -50 topdot " - append index [string trim $seg] - } else { - if {[string is digit [string trim $seg]]} { - set basenum [trimzero [string trim $seg]] - set lengthindex "[padleft [string length $basenum] 5]-d" - append index "$lengthindex " - #append index [padleft $basenum 40] - append index $basenum - } else { - append index [string trim $seg] - } - } - incr s - } - puts stdout ">>$index" - db_sort_basic eval {insert into sqlitesort values($index,$nm)} - } - db_sort_basic eval [string map [list %collate% $collate] {select name from sqlitesort order by index0 COLLATE %collate% ASC, name COLLATE %collate% ASC }] { - lappend orderedlist $name - } - db_sort_basic close - return $orderedlist - } - - proc get_leading_char_count {str char} { - #todo - something more elegant? regex? - set count 0 - foreach c [split $str "" ] { - if {$c eq $char} { - incr count - } else { - break - } - } - return $count - } - proc stacktrace {} { - set stack "Stack trace:\n" - for {set i 1} {$i < [info level]} {incr i} { - set lvl [info level -$i] - set pname [lindex $lvl 0] - append stack [string repeat " " $i]$pname - - if {![catch {info args $pname} pargs]} { - foreach value [lrange $lvl 1 end] arg $pargs { - - if {$value eq ""} { - if {$arg != 0} { - info default $pname $arg value - } - } - append stack " $arg='$value'" - } - } else { - append stack " !unknown vars for $pname" - } - - append stack \n - } - return $stack - } - - proc get_char_count {str char} { - #faster than lsearch on split for str of a few K - expr {[string length $str]-[string length [string map [list $char {}] $str]]} - } - - proc build_key {chunk splitchars topdict tagconfig debug} { - variable stacktrace_on - if {$stacktrace_on} { - puts stderr "+++>[stacktrace]" - } - - set index_map [list - "" _ ""] - #e.g - need to maintain the order - #a b.txt - #a book.txt - #ab.txt - #abacus.txt - - - set original_splitchars [dict get $tagconfig original_splitchars] - - # tag_dashes test moved from loop - review - set tag_dashes 0 - if {![string length [dict get $tagconfig last_part_text_tag]]} { - #winlike - set tag_dashes 1 - } - if {("-" ni $original_splitchars)} { - set tag_dashes 1 - } - if {$debug >= 3} { - puts stdout "START build_key chunk : $chunk" - puts stdout "START build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" - } - - - ## index_map will have no effect if we've already split on the char anyway(?) - #foreach m [dict keys $index_map] { - # if {$m in $original_splitchars} { - # dict unset index_map $m - # } - #} - - #if {![string length $chunk]} return - - set result "" - if {![llength $splitchars]} { - #no more structural splits - but we need to examine numeric/non-numeric segments at the lowest level. - # we are at a leaf in the recursive split hierarchy - - set s "" ;#we never actually split on "" (unless that was put in splitchars.. but it probably shouldn't be) - set parts [list $chunk] ;#important to treat as list or leading/trailing whitespace lost - - - } else { - set s [lindex $splitchars 0] - if {"spudbucket$s" in "[split $chunk {}]"} { - error "dead-branch spudbucket" - set partindex [build_key $chunk [lrange $splitchars 1 end] $topdict $tagconfig $debug] - if {[dict get $tagconfig showsplits]} { - set pfx "(1${s}=)" ;# = sorts before _ - set partindex ${pfx}$partindex - } - - return $partindex - } else { - set parts_below_index "" - - if {$s ni [split $chunk ""]} { - #$s can be an empty string - set parts [list $chunk] - } else { - set parts [split $chunk $s] ;#whitespace preserved - even if splitting on s that is not in string. - } - #assert - we have a splitchar $s that is in the chunk - so at least one part - if {(![string length $s] || [llength $parts] == 0)} { - error "buld_key assertion false empty split char and/or no parts" - } - - set pnum 1 ;# 1 based for clarity of reading index in debug output - set subpart_count [llength $parts] - - set sub_splits [lrange $splitchars 1 end] ;#pass same splitchars to each subpart - foreach p $parts { - set partindex [build_key $p $sub_splits $topdict $tagconfig $debug] - set lastpart [expr {$pnum == $subpart_count}] - - - ####################### - set showsplits [dict get $tagconfig showsplits] - #split prefixing experiment - maybe not suitable for general use - as it affects sort order - #note that pfx must be consistent until last one, no matter how many partnumbers there are in total. - # we don't want to influence sort order before reaching end. - #e.g for: - #(1.=)... - #(1._)...(2._)...(3.=) - #(1._)...(2.=) - #Note that this is probably more suitable for highly structure dependant sorts where the results are maybe less.. natural. - if {$showsplits} { - if {$lastpart} { - set pfx "(${pnum}${s}_" - #set pfx "(${pnum}${s}=)" ;# = sorts before _ - } else { - set pfx "(${pnum}${s}_" - } - append parts_below_index $pfx - } - ####################### - - if {$lastpart} { - if {[string length $p] && [string is digit $p]} { - set last_part_tag "<22${s}>" - } else { - set last_part_tag "<33${s}>" - } - - set last_part_text_tag [dict get $tagconfig last_part_text_tag] - #for -winlike 1 there is no tag configured. Windows explorer likes to put things in the order: - # module-0.1.1.tm - # module-0.1.1.2.tm - # module-0.1.tm - # arguably -winlike 0 is more natural/human - # module-0.1.tm - # module-0.1.1.tm - # module-0.1.1.2.tm - - if {[string length $last_part_text_tag]} { - #replace only the first text-tag (<30>) from the subpart_index - if {[string match "<30?>*" $partindex]} { - #give textual string index a specific tag for last part in split only. e.g <130> for lower than integers - set partindex "<130>[string range $partindex 5 end]" - } - #append parts_below_index $last_part_tag - } - #set partindex $last_part_tag$partindex - - - } - append parts_below_index $partindex - - - - if {$showsplits} { - if {$lastpart} { - set suffix "${pnum}${s}=)" ;# = sorts before _ - } else { - set suffix "${pnum}${s}_)" - } - append parts_below_index $suffix - } - - - incr pnum - } - append parts_below_index "" ;# don't add anything at the tail that may perturb sort order - - if {$debug >= 3} { - set pad [string repeat " " 20] - puts stdout "END build_key chunk : $chunk " - puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" - puts stdout "END build_key ret below_index: $parts_below_index" - } - return $parts_below_index - - - } - } - - - - #puts stdout ">>>chunk:'$chunk'<<< split-on:$s parts: '$parts' splitchars: $splitchars -topdict:$topdict" - - - - - - #if {$chunk eq ""} { - # puts "___________________________________________!!!____" - #} - #puts stdout "-->chunk:$chunk $s parts:$parts" - - #puts stdout "---chunk:'$chunk' part:'$part' parts:'$parts' s:'$s'" - - - - - set segments [split_numeric_segments $chunk] ;#! - set stringindex "" - set segnum 0 - foreach seg $segments { - #puts stdout "=================---->seg:$seg segments:$segments" - #-strict ? - if {[string length $seg] && [string is digit $seg]} { - set basenum [trimzero [string trim $seg]] - set lengthindex "[padleft [string length $basenum] 4]d" - #append stringindex "<20>$lengthindex $basenum $seg" - } else { - set c1 [string range $seg 0 0] - #puts stdout "==============> c1'$c1' topdict: $topdict stringindex:$stringindex" - - if {$c1 in [dict keys $topdict]} { - set tag [dict get $topdict $c1] - #append stringindex "${tag}$c1" - #set seg [string range $seg 1 end] - } - #textindex - set leader "<30>" - set idx $seg - set idx [string trim $idx] - set idx [string tolower $idx] - set idx [string map $index_map $idx] - - - - - - #set the X-c count to match the length of the index - not the raw data - set lengthindex "[padleft [string length $idx] 4]c" - - #append stringindex "${leader}$idx $lengthindex $texttail" - } - } - - if {[llength $parts] != 1} { - error "build_key assertion fail llength parts != 1 parts:$parts" - } - - set segtail_clearance_buffer " " ;#space to clear other split indicators if using showsplits - set segtail $segtail_clearance_buffer - append segtail "\[" - set grouping "" - set pnum 0 - foreach p $parts { - set sublen_list [list] - set subsegments [split_numeric_segments $p] - set i 0 - - set partsorter "" - foreach sub $subsegments { - ##don't trim spaces here - it would be inconsistent. Some subs are pure whitespace - others have internal whitespace. e.g "a4 400b a b2" becomes "a 4 { } 400 {b a b} 2" - #mapping away all whitespace would be consistent, but not necessarily desirable. If it's in the index_map it'll happen anyway - so we don't do it manually here except for evaluating conditions. - set test_trim [string trim $sub] - set str $sub - set str [string tolower $str] - set str [string map $index_map $str] - if {[string length $test_trim] && [string is digit $test_trim]} { - append partsorter [trimzero $str] - } else { - append partsorter "$str" - } - append partsorter - } - - - foreach sub $subsegments { - - if {[string length $sub] && [string is digit $sub]} { - set basenum [trimzero [string trim $sub]] - set subequivs $basenum - set lengthindex "[padleft [string length $subequivs] 4]d " - set idx "$lengthindex [padleft $basenum 10]" ;#todo - cycle through data and determine longest - set tail [overtype::left [string repeat " " 10] $sub] - #set tail "" - } else { - set idx "" - - - set lookahead [lindex $subsegments $i+1] - if {![string length $lookahead]} { - set zeronum "[padleft 0 4]d0" - } else { - set zeronum "" - } - set subequivs $sub - #set subequivs [string trim $subequivs] - set subequivs [string tolower $subequivs] - set subequivs [string map $index_map $subequivs] - - append idx $subequivs - append idx $zeronum - - set idx $subequivs - - - # - - set ch "-" - if {$tag_dashes} { - #puts stdout "____TAG DASHES" - #winlike - set numleading [get_leading_char_count $seg $ch] - if {$numleading > 0} { - set texttail "<31-leading[padleft $numleading 4]$ch>" - } else { - set texttail "<30>" - } - set numothers [expr {[get_char_count $seg $ch] - $numleading}] - if {$debug >= 2} { - puts stdout "____dashcount: [get_char_count $seg $ch] numothers: $numothers" - } - if {$numothers > 0} { - append texttail "<31-others[padleft $numothers 4]$ch>" - } else { - append textail "<30>" - } - } else { - set texttail "<30>" - } - - - - - #set idx $partsorter - set tail "" - #set tail [string tolower $sub] ;#raw - #set tail $partsorter - #append tail ":[string tolower $p]" ;#we need the whole part - even though it makes the index much larger. !todo - tagconfig switch to toggle case sensitive sorting - } - - append grouping "$idx $tail|$s" - incr i - } - - - - - - if {$p eq ""} { - # no subsegments.. - set zeronum "[padleft 0 4]d0" - #append grouping "\u000$zerotail" - append grouping ".$zeronum" - } - - #append grouping | - #append grouping $s - #foreach len $sublen_list { - # append segtail "<[padleft $len 3]>" - #} - incr pnum - } - set grouping [string trimright $grouping $s] - append grouping "[padleft [llength $parts] 4]" - append segtail $grouping - - - #append segtail " <[padleft [llength $parts] 4]>" - - append segtail "\]" - - - #if {[string length $seg] && [string is digit $seg]} { - # append segtail "<20>" - #} else { - # append segtail "<30>" - #} - append stringindex $segtail - - incr segnum - - - - - lappend indices $stringindex - - if {[llength $indices] > 1} { - puts stderr "INDICES [llength $indices]: $stringindex" - error "build_key assertion error deadconcept indices" - } - - #topchar handling on splitter characters - #set c1 [string range $chunk 0 0] - if {$s in [dict keys $topdict]} { - set tag [dict get $topdict $s] - set joiner [string map [list ">" "$s>"] ${tag}] - #we have split on this character $s so if the first part is empty string then $s was a leading character - # we need to bring a tag out front for this, or it will be dominated by the leading sections-remaing tag - # (since the empty string produces no tag of it's own - ?) - if {[string length [lindex $parts 0]] == 0} { - set prefix ${joiner} - } else { - set prefix "" - } - } else { - #use standard character-data positioning tag if no override from topdict - set joiner "<30J>$s" - set prefix "" - } - - - set contentindex $prefix[join $indices $joiner] - if {[string length $s]} { - set split_indicator "" - } else { - set split_indicator "" - - } - if {![string length $s]} { - set s ~ - } - - #return "[overtype::left [string repeat { } 80] $contentindex][overtype::left [string repeat { } 10] [list $s $chunk]]" - #return $contentindex$split_indicator - #return [overtype::left [string repeat - 40] $contentindex] - - if {$debug >= 3} { - puts stdout "END build_key chunk : $chunk" - puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" - puts stdout "END build_key ret contentidx : $contentindex" - } - return $contentindex - } - - #---------------------------------------- - #line-processors - data always last argument - opts can be empty string - #all processor should accept empty opts and ignore opts if they don't use them - proc _lineinput_as_tcl1 {opts line} { - set out "" - foreach i $line { - append out "$i " - } - set out [string range $out 0 end-1] - return $out - } - #should be equivalent to above - proc _lineinput_as_tcl {opts line} { - return [concat {*}$line] - } - #will put extra tcl quoting if it was already tcl-shaped e.g text "a" -> {"a"} - proc _lineoutput_as_tcl {opts line} { - return [regexp -inline -all {\S+} $line] - } - - proc _lineinput_as_raw {opts line} { - return $line - } - proc _lineoutput_as_raw {opts line} { - return $line - } - - #words is opposite of tcl - proc _lineinput_as_words {opts line} { - #wordlike_parts - return [regexp -inline -all {\S+} $line] - } - proc _lineoutput_as_words {opts line} { - return [concat {*}$line] - } - - #opts same as tcllib csv::split - except without the 'line' element - #?-alternate? ?sepChar? ?delChar? - proc _lineinput_as_csv {opts line} { - package require csv - if {[lindex $opts 0] eq "-alternate"} { - return [csv::split -alternate $line {*}[lrange $opts 1 end]] - } else { - return [csv::split $line {*}$opts] - } - } - #opts same as tcllib csv::join - #?sepChar? ?delChar? ?delMode? - proc _lineoutput_as_csv {opts line} { - package require csv - return [csv::join $line {*}$opts] - } - #---------------------------------------- - proc sort {stringlist args} { - #puts stdout "natsort::sort args: $args" - variable debug - if {![llength $stringlist]} return - - #allow pass through of the check_flags flag -debugargs so it can be set by the caller - set debugargs 0 - if {[set posn [lsearch $args -debugargs]] >=0} { - if {$posn == [llength $args]-1} { - #-debugargs at tail of list - set debugargs 1 - } else { - set debugargs [lindex $args $posn+1] - } - } - - #-return flagged|defaults doesn't work Review. - #flagfilter global processor/allocator not working 2023-08 - set args [check_flags \ - -caller natsort::sort \ - -return supplied|defaults \ - -debugargs $debugargs \ - -defaults [list -collate nocase \ - -winlike 0 \ - -splits "\uFFFF" \ - -topchars {. _} \ - -showsplits 1 \ - -sortmethod ascii \ - -collate "\uFFFF" \ - -inputformat raw \ - -inputformatapply {index data} \ - -inputformatoptions "" \ - -outputformat raw \ - -outputformatoptions "" \ - -cols "\uFFFF" \ - -debug 0 -db "" -stacktrace 0 -splits "\uFFFF" -showsplits 0] \ - -required {all} \ - -extras {none} \ - -commandprocessors {} \ - -values $args] - - #csv unimplemented - - set winlike [dict get $args -winlike] - set topchars [dict get $args -topchars] - set cols [dict get $args -cols] - set debug [dict get $args -debug] - set stacktrace [dict get $args -stacktrace] - set showsplits [dict get $args -showsplits] - set splits [dict get $args -splits] - set sortmethod [dict get $args -sortmethod] - set opt_collate [dict get $args -collate] - set opt_inputformat [dict get $args -inputformat] - set opt_inputformatapply [dict get $args -inputformatapply] - set opt_inputformatoptions [dict get $args -inputformatoptions] - set opt_outputformat [dict get $args -outputformat] - set opt_outputformatoptions [dict get $args -outputformatoptions] - dict unset args -showsplits - dict unset args -splits - if {$debug} { - puts stdout "natsort::sort processed_args: $args" - if {$debug == 1} { - puts stdout "natsort::sort - try also -debug 2, -debug 3" - } - } - - #set sortmethod "-dictionary" ;# sorts a2b before a001b - possibly other strangenesses that are hard to reason about - - if {$sortmethod in [list dictionary ascii]} { - set sortmethod "-$sortmethod" - # -ascii is default for tcl lsort. - } else { - set sortmethod "-ascii" - } - - set allowed_collations [list nocase] - if {$opt_collate ne "\uFFFF"} { - if {$opt_collate ni $allowed_collations} { - error "natsort::sort unknown value for -collate option. Only acceptable value(s): $allowed_collations" - } - set nocaseopt "-$opt_collate" - } else { - set nocaseopt "" - } - set allowed_inputformats [list tcl raw csv words] - if {$opt_inputformat ni $allowed_inputformats} { - error "natsort::sort unknown value for -inputformat option. Only acceptable value(s): $allowed_inputformats" - } - set allowed_outputformats [list tcl raw csv words] - if {$opt_inputformat ni $allowed_outputformats} { - error "natsort::sort unknown value for -outputformat option. Only acceptable value(s): $allowed_outputformats" - } - - # - set winsplits [list / . _] - set commonsplits [list / . _ -] - #set commonsplits [list] - - set tagconfig [dict create] - dict set tagconfig last_part_text_tag "<19>" - if {$winlike} { - set splitchars $winsplits - #windows explorer sorts leading spaces at the top - which doesn't seem very helpful for keeping things together - but the explorer doesn't seem able to create leading spaces anyway. - set wintop [list "(" ")" { } {.} {_}] ;#windows specific order - foreach t $topchars { - if {$t ni $wintop} { - lappend wintop $t - } - } - set topchars $wintop - dict set tagconfig last_part_text_tag "" - } else { - set splitchars $commonsplits - } - if {$splits ne "\uFFFF"} { - set splitchars $splits - } - dict set tagconfig original_splitchars $splitchars - dict set tagconfig showsplits $showsplits - - #create topdict - set i 0 - set topdict [dict create] - foreach c $topchars { - incr i ;#start at 01 so that 00 reserved for final-split tag (allows x-0.1.txt to sort above x-0.1.1.txt by default. Use tagconfig to change, or choose -winlike 1 for explorer-like sorting) - dict set topdict $c "<0$i>" - } - set keylist [list] - - - if {$opt_inputformat eq "tcl"} { - set lineinput_transform [list _lineinput_as_tcl $opt_inputformatoptions] - } elseif {$opt_inputformat eq "csv"} { - set lineinput_transform [list _lineinput_as_csv $opt_inputformatoptions] - } elseif {$opt_inputformat eq "raw"} { - set lineinput_transform [list _lineinput_as_raw $opt_inputformatoptions] - } elseif {$opt_inputformat eq "words"} { - set lineinput_transform [list _lineinput_as_words $opt_inputformatoptions] - } - if {$opt_outputformat eq "tcl"} { - set lineoutput_transform [list _lineoutput_as_tcl $opt_outputformatoptions] - } elseif {$opt_outputformat eq "csv"} { - set lineoutput_transform [list _lineoutput_as_csv $opt_outputformatoptions] - } elseif {$opt_outputformat eq "raw"} { - set lineoutput_transform [list _lineoutput_as_raw $opt_outputformatoptions] - } elseif {$opt_outputformat eq "words"} { - set lineoutput_transform [list _lineoutput_as_words $opt_outputformatoptions] - } - - - if {("data" in $opt_inputformatapply) || ("index" in $opt_inputformatapply)} { - if {$opt_inputformat eq "raw"} { - set tf_stringlist $stringlist - } else { - set tf_stringlist [list] - foreach v $stringlist { - lappend tf_stringlist [{*}$lineinput_transform $v] - } - } - if {"data" in $opt_inputformatapply} { - set tf_data_stringlist $tf_stringlist - } else { - set tf_data_stringlist $stringlist - } - if {"index" in $opt_inputformatapply} { - set tf_index_stringlist $tf_stringlist - } else { - set tf_index_stringlist $stringlist - } - } else { - set tf_data_stringlist $stringlist - set tf_index_stringlist $stringlist - } - - - - if {$stacktrace} { - puts stdout [natsort::stacktrace] - set natsort::stacktrace_on 1 - } - if {$cols eq "\uFFFF"} { - set colkeys [lmap v $stringlist {}] - } else { - set colkeys [list] - foreach v $tf_index_stringlist { - set lineparts $v - set k [list] - foreach c $cols { - lappend k [lindex $lineparts $c] - } - lappend colkeys [join $k "_"] ;#use a common-split char - Review - } - } - #puts stdout "colkeys: $colkeys" - - if {$opt_inputformat eq "raw"} { - #no inputformat was applied - can just use stringlist - foreach value $stringlist ck $colkeys { - set contentindex [build_key $value $splitchars $topdict $tagconfig $debug] - set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] - lappend keylist ${colindex}-${contentindex}-$value ;#note: entire raw value used for final sort disambiguation (can be whitespace that was ignored in indexing) - } - } else { - foreach keyinput $tf_index_stringlist datavalue $tf_data_stringlist ck $colkeys { - #data may or may not have been transformed - #column index may or may not have been built with transformed data - - set contentindex [build_key $keyinput $splitchars $topdict $tagconfig $debug] - set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] - lappend keylist ${colindex}-${contentindex}-$datavalue ;#note: entire value used for final sort disambiguation (can be whitespace that was ignored in indexing) - } - } - #puts stderr "keylist: $keylist" - - ################################################################################################### - # Use the generated keylist to do the actual sorting - # select either the transformed or raw data as the corresponding output - ################################################################################################### - if {[string length $nocaseopt]} { - set sortcommand [list lsort $sortmethod $nocaseopt -indices $keylist] - } else { - set sortcommand [list lsort $sortmethod -indices $keylist] - } - if {$opt_outputformat eq "raw"} { - #raw output means no further transformations - it doesn't mean there wasn't a transform applied on the input side - #use the tf_data_stringlist in the output - which will be the same as the input stringlist if no input transform applied for data. - #(Also - it may or may not have been *sorted* on transformed data depending on whether 'index' was in $opt_inputformatapply) - foreach idx [{*}$sortcommand] { - lappend result [lindex $tf_data_stringlist $idx] - } - } else { - #we need to apply an output format - #The data may or may not have been transformed at input - foreach idx [{*}$sortcommand] { - lappend result [{*}$lineoutput_transform [lindex $tf_data_stringlist $idx]] - } - } - ################################################################################################### - - - - - - if {$debug >= 2} { - set screen_width 250 - set max_val 0 - set max_idx 0 - ##### calculate colum widths - foreach i [{*}$sortcommand] { - set len_val [string length [lindex $stringlist $i]] - if {$len_val > $max_val} { - set max_val $len_val - } - set len_idx [string length [lindex $keylist $i]] - if {$len_idx > $max_idx} { - set max_idx $len_idx - } - } - #### - set l_width [expr {$max_val + 1}] - set leftcol [string repeat " " $l_width] - set r_width [expr {$screen_width - $l_width - 1}] - set rightcol [string repeat " " $r_width] - set str [overtype::left $leftcol RAW] - puts stdout " $str Index with possibly transformed data at tail" - foreach i [{*}$sortcommand] { - #puts stdout "|d> [overtype::left $leftcol [lindex $stringlist $i] ] [lindex $keylist $i]" - set index [lindex $keylist $i] - set len_idx [string length $index] - set rowcount [expr {$len_idx / $r_width}] - if {($len_idx % $r_width) > 0} { - incr rowcount - } - set rows [list] - for {set r 0} {$r < $rowcount} {incr r} { - lappend rows [string range $index 0 $r_width-$r] - set index [string range $index $r_width end] - } - - set r 0 - foreach idxpart $rows { - if {$r == 0} { - #use the untransformed stringlist - set str [overtype::left $leftcol [lindex $stringlist $i]] - } else { - set str [overtype::left $leftcol ...]] - } - puts stdout " $str $idxpart" - incr r - } - #puts stdout "|> '[lindex $stringlist $i]'" - #puts stdout "|> [lindex $keylist $i]" - } - - puts stdout "|debug> topdict: $topdict" - puts stdout "|debug> splitchars: $splitchars" - } - return $result - } - - - - #Note that although leading whitespace isn't a commonly used feature of filesystem names - it's possible at least on FreeBSD,windows and linux so we should try to handle it sensibly. - proc sort_experiment {stringlist args} { - package require sqlite3 - - variable debug - set args [check_flags -caller natsort::sort \ - -defaults [dict create -db :memory: -collate nocase -nullvalue "->NULL<" -winlike 0 -topchars [list] -debug 0] \ - -extras {all} \ - -values $args] - set db [string trim [dict get $args -db]] - set collate [string trim [dict get $args -collate]] - set winlike [string trim [dict get $args -winlike]] - set debug [string trim [dict get $args -debug]] - set nullvalue [string trim [dict get $args -nullvalue]] - - - set topchars [string trim [dict get $args -topchars]] - - set topdot [expr {"." in $topchars}] - set topunderscore [expr {"_" in $topchars}] - - - sqlite3 db_natsort2 $db - #-- - #our table must handle the name with the greatest number of numeric/non-numeric splits. - #This means a single list member with pathological naming e.g a1a1a1a1a1a1a1a1a1a1a1.txt could greatly extend the number of columns and indices and affect performance. - #review: could be optimised to aggregate the tail into a single index, as the the extra columns won't assist in ordering, but make the table and query bigger. - # we should probably determine the longest common sequence of splits in the input list and add only one more index for the segment after that. - set maxsegments 0 - #-- - set prefix "idx" - - #note - there will be more columns in the sorting table than segments. - # (a segment equals one of the numeric & non-numeric string portions returned from 'split_numeric_sgements') - #--------------------------- - # consider - # a123b.v1.2.txt - # a123b.v1.3beta1.txt - # these have the following segments: - # a 123 b.v 1 . 2 .txt - # a 123 b.v 1 . 3 beta 1 .txt - #--------------------------- - # The first string has 7 segments (numbered 0 to 6) - # the second string has 9 segments - # - # for example when the data has any elements in a segment position that are numeric (e.g 0001 123) - # - then an index column with numeric equivalents will be created (e.g 0001 becomes 1), and any non-numeric values in that column will get mapped to a negative value (for special cases) or a high value such as NULL (with NULLS LAST sql support) - # - # when a segment - - #cycle through all strings - we cannot build tabledef as we go because the column type depends on whether all segments for a particular column are text vs int-equivalent. - array set segmentinfo {} - foreach nm $stringlist { - set segments [split_numeric_segments $nm] - if {![string length [string trim [lindex $segments 0]]]} { - if {[string is digit [string trim [lindex $segments 1]]]} { - #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though) - set segments [lrange $segments 1 end] - } - } - - - set c 0 ;#start of index columns - if {[llength $segments] > $maxsegments} { - set maxsegments [llength $segments] - } - foreach seg $segments { - set seg [string trim $seg] - set column_exists [info exists segmentinfo($c,type)] - if {[string is digit $seg]} { - if {$column_exists} { - #override it (may currently be text or int) - set segmentinfo($c,type) "int" - } else { - #new column - set segmentinfo($c,name) ${prefix}$c - set segmentinfo($c,type) "int" - } - } else { - #text never overrides int - if {!$column_exists} { - set segmentinfo($c,name) ${prefix}$c - set segmentinfo($c,type) "text" - } - } - incr c - } - } - if {$debug} { - puts stdout "Largest number of num/non-num segments in data: $maxsegments" - #parray segmentinfo - } - - # - set tabledef "" - set ordered_column_names [list] - set ordered_segmentinfo_tags [lsort -dictionary [array names segmentinfo *]] - foreach k $ordered_segmentinfo_tags { - lassign [split $k ,] c tag - if {$tag eq "type"} { - set type [set segmentinfo($k)] - if {$type eq "int"} { - append tabledef "$segmentinfo($c,name) int," - } else { - append tabledef "$segmentinfo($c,name) text COLLATE $collate," - } - append tabledef "raw$c text COLLATE $collate," - lappend ordered_column_names $segmentinfo($c,name) - lappend ordered_column_names raw$c ;#additional index column not in segmentinfo - } - if {$tag eq "name"} { - #lappend ordered_column_names $segmentinfo($k) - } - } - append tabledef "name text" - - #puts stdout "tabledef:$tabledef" - - - db_natsort2 eval [string map [list %tabledef% $tabledef] {create table natsort(%tabledef%)}] - - - foreach nm $stringlist { - array unset intdata - array set intdata {} - array set rawdata {} - #init array and build sql values string - set sql_insert "insert into natsort values(" - for {set i 0} {$i < $maxsegments} {incr i} { - set intdata($i) "" - set rawdata($i) "" - append sql_insert "\$intdata($i),\$rawdata($i)," - } - append sql_insert "\$nm" ;#don't manipulate name value in any way - e.g must leave all whitespace as the sort must return exactly the same elements as in the original list. - append sql_insert ")" - - set segments [split_numeric_segments $nm] - if {![string length [string trim [lindex $segments 0]]]} { - if {[string is digit [string trim [lindex $segments 1]]]} { - #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though) - set segments [lrange $segments 1 end] - } - } - set values "" - set c 0 - foreach seg $segments { - if {[set segmentinfo($c,type)] eq "int"} { - if {[string is digit [string trim $seg]]} { - set intdata($c) [trimzero [string trim $seg]] - } else { - catch {unset intdata($c)} ;#set NULL - sorts last - if {($c == 0) && ($topunderscore) && [string match _* [string trim $seg]]} { - set intdata($c) -100 - } - if {($c == 0) && ($topdot) && [string match .* [string trim $seg]]} { - set intdata($c) -50 - } - } - set rawdata($c) [string trim $seg] - } else { - #pure text column - #set intdata($c) [string trim $seg] ;#ignore leading/trailing whitespace - we sort first on trimmed version, then refine with the sort on rawdata index - #catch {unset indata($c)} - set indata($c) [string trim $seg] - set rawdata($c) $seg - } - #set rawdata($c) [string trim $seg]# - #set rawdata($c) $seg - incr c - } - db_natsort2 eval $sql_insert - } - - set orderedlist [list] - - if {$debug} { - db_natsort2 eval {select * from pragma_table_info('natsort')} rowdata { - parray rowdata - } - } - set orderby "order by " - - foreach cname $ordered_column_names { - if {[string match "idx*" $cname]} { - append orderby "$cname ASC NULLS LAST," - } else { - append orderby "$cname ASC," - } - } - append orderby " name ASC" - #append orderby " NULLS LAST" ;#?? - - #e.g "order by idx0 ASC, raw0 ASC, idx1 ASC .... name ASC" - if {$debug} { - puts stdout "orderby clause: $orderby" - } - db_natsort2 eval [string map [list %orderby% $orderby] {select * from natsort %orderby%}] rowdata { - set line "- " - #parray rowdata - set columnnames $rowdata(*) - #puts stdout "columnnames: $columnnames" - #[lsort -dictionary [array names rowdata] - append line "$rowdata(name) \n" - foreach nm $columnnames { - if {$nm ne "name"} { - append line "$nm: $rowdata($nm) " - } - } - #puts stdout $line - #puts stdout "$rowdata(name)" - lappend orderedlist $rowdata(name) - } - - db_natsort2 close - return $orderedlist - } -} - - -#application section e.g this file might be linked from /usr/local/bin/natsort -namespace eval natsort { - namespace import ::flagfilter::check_flags - - proc called_directly_namematch {} { - global argv0 - #see https://wiki.tcl-lang.org/page/main+script - #trailing ... let's us resolve symlinks in last component of the path (could be something else like ___ but ... seems unlikely to collide with anything in the filesystem) - if {[info exists argv0] - && - [file dirname [file normalize [file join [info script] ...]]] - eq - [file dirname [file normalize [file join $argv0 ...]]] - } { - return 1 - } else { - #puts stdout "norm info script: [file dirname [file normalize [file join [info script] ...]]]" - #puts stdout "norm argv0 : [file dirname [file normalize [file join $argv0 ...]]]" - return 0 - } - } - #Review issues around comparing names vs using inodes (esp with respect to samba shares) - proc called_directly_inodematch {} { - global argv0 - if {[info exists argv0] - && [file exists [info script]] && [file exists $argv0]} { - file stat $argv0 argv0Info - file stat [info script] scriptInfo - expr {$argv0Info(dev) == $scriptInfo(dev) - && $argv0Info(ino) == $scriptInfo(ino)} - } else { - return 0 - } - } - - set is_namematch [called_directly_namematch] - set is_inodematch [called_directly_inodematch] - #### - #review - reliability of mechanisms to determine direct calls - # we don't want application being called when being used as a library, but we need it to run if called directly or from symlinks etc - #-- choose a policy and leave the others commented. - #set is_called_directly $is_namematch - #set is_called_directly $is_inodematch - set is_called_directly [expr {$is_namematch || $is_inodematch}] - #set is_called_directly [expr {$is_namematch && $is_inodematch}] - ### - - - #puts stdout "called_directly_name: [called_directly_namematch] called_directly_inode: [called_directly_inodematch]" - - - # - - - proc test_pass_fail_message {pass {additional ""}} { - variable test_fail_msg - variable test_pass_msg - if {$pass} { - puts stderr $test_pass_msg - } else { - puts stderr $test_fail_msg - } - puts stderr $additional - } - - variable test_fail_msg "XXXXXXXXXXXX FAIL XXXXXXXXXXXXX" - variable test_pass_msg "------------ PASS -------------" - proc test_sort_1 {args} { - package require struct::list - puts stderr "---$args" - set args [check_flags -caller natsort:test_sort_1 -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] -values $args] - - puts stderr "test_sort_1 got args: $args" - - set unsorted_input { - 2.2.2 - 2.2.2.2 - 1a.1.1 - 1a.2.1.1 - 1.12.1 - 1.2.1.1 - 1.02.1.1 - 1.002b.1.1 - 1.1.1.2 - 1.1.1.1 - } - set input { -1.1.1 -1.1.1.2 -1.002b.1.1 -1.02.1.1 -1.2.1.1 -1.12.1 -1a.1.1 -1a.2.1.1 -2.2.2 -2.2.2.2 - } - - set sorted [natsort::sort $input {*}$args] - set is_match [struct::list equal $input $sorted] - - set msg "windows-explorer order" - - test_pass_fail_message $is_match $msg - puts stdout [string repeat - 40] - puts stdout INPUT - puts stdout [string repeat - 40] - foreach item $input { - puts stdout $item - } - puts stdout [string repeat - 40] - puts stdout OUTPUT - puts stdout [string repeat - 40] - foreach item $sorted { - puts stdout $item - } - test_pass_fail_message $is_match $msg - return [expr {!$is_match}] - } - proc test_sort_showsplits {args} { - package require struct::list - - set args [check_flags -caller natsort:test_sort_1 \ - -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 1 ] \ - -extras {all} \ - -values $args] - - set input1 { - a-b.txt - a.b.c.txt - b.c-txt - } - - - set input2 { - a.b.c.txt - a-b.txt - b.c-text - } - - foreach {msg testlist } [list "custom-order" $input1 "windows-explorer (should work with -winlike 1)" $input2] { - set sorted [natsort::sort $testlist {*}$args] - set is_match [struct::list equal $testlist $sorted] - - test_pass_fail_message $is_match $msg - puts stderr "INPUT" - puts stderr "[string repeat - 40]" - foreach item $testlist { - puts stdout $item - } - puts stderr "[string repeat - 40]" - puts stderr "OUTPUT" - puts stderr "[string repeat - 40]" - foreach item $sorted { - puts stdout $item - } - - test_pass_fail_message $is_match $msg - } - - #return [expr {!$is_match}] - - } - - #tcl dispatch order - non flag items up front - #trailing flags are paired even if supplied as solo flags e.g -l becomes -l 1 - proc commandline_ls {args} { - set operands [list] - set posn 0 - foreach a $args { - if {![string match -* $a]} { - lappend operands $a - } else { - set flag1_posn $posn - break - } - incr posn - } - set args [lrange $args $flag1_posn end] - - - set debug 0 - set posn [lsearch $args -debug] - if {$posn > 0} { - if {[lindex $args $posn+1]} { - set debug [lindex $args $posn+1] - } - } - if {$debug} { - puts stderr "|debug>commandline_ls got $args" - } - - #if first operand not supplied - replace it with current working dir - if {[lindex $operands 0] eq "\uFFFF"} { - lset operands 0 [pwd] - } - - set targets [list] - foreach op $operands { - if {$op ne "\uFFFF"} { - set opchars [split [file tail $op] ""] - if {"?" in $opchars || "*" in $opchars} { - lappend targets $op - } else { - #actual file or dir - set targetitem $op - set targetitem [file normalize $op] - if {![file exists $targetitem]} { - if {$debug} { - puts stderr "|debug>commandline_ls Unable to access path '$targetitem'" - } - } - lappend targets $targetitem - if {$debug} { - puts stderr "|debug>commandline_ls listing for $targetitem" - } - } - } - } - set args [check_flags -caller commandline_ls \ - -return flagged|defaults \ - -debugargs 0 \ - -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 -algorithm sort] \ - -required {all} \ - -extras {all} \ - -soloflags {-v -l} \ - -commandprocessors {} \ - -values $args ] - if {$debug} { - puts stderr "|debug>args: $args" - } - - - set algorithm [dict get $args -algorithm] - dict unset args -algorithm - - set allfolders [list] - set allfiles [list] - foreach item $targets { - if {[file exists $item]} { - if {[file type $item] eq "directory"} { - set dotfolders [glob -nocomplain -directory $item -type {d} -tail .*] - set folders [glob -nocomplain -directory $item -type {d} -tail *] - set allfolders [concat $allfolders $dotfolders $folders] - - set dotfiles [glob -nocomplain -directory $item -type {f} -tail .*] - set files [glob -nocomplain -directory $item -type {f} -tail *] - set allfiles [concat $allfiles $dotfiles $files] - } else { - #file (or link?) - set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]] - set allfiles [concat $allfiles $files] - } - } else { - set folders [glob -nocomplain -directory $item -type {d} -tail [file tail $item]] - set allfolders [concat $allfolders $folders] - set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]] - set allfiles [concat $allfiles $files] - } - } - - - set sorted_folders [natsort::sort $allfolders {*}$args] - set sorted_files [natsort::sort $allfiles {*}$args] - - foreach fold $sorted_folders { - puts stdout $fold - } - foreach file $sorted_files { - puts stdout $file - } - - return "-- ok printed to stdout [llength $sorted_folders] folders and [llength $sorted_files] files --" - } - - package require argp - argp::registerArgs commandline_test { - { -showsplits boolean 0} - { -stacktrace boolean 0} - { -debug boolean 0} - { -winlike boolean 0} - { -db string ":memory:"} - { -collate string "nocase"} - { -algorithm string "sort"} - { -topchars string "\uFFFF"} - { -testlist string {10 1 30 3}} - } - argp::setArgsNeeded commandline_test {-stacktrace} - proc commandline_test {test args} { - variable testlist - puts stdout "commandline_test got $args" - argp::parseArgs opts - puts stdout "commandline_test got [array get opts]" - set args [check_flags -caller natsort_commandline \ - -return flagged|defaults \ - -defaults [list -db :memory: -collate nocase -testlist $testlist -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ - -values $args] - - if {[string tolower $test] in [list "1" "true"]} { - set test "sort" - } else { - if {![llength [info commands $test]]} { - error "test $test not found" - } - } - dict unset args -test - set stacktrace [dict get $args -stacktrace] - # dict unset args -stacktrace - - set argtestlist [dict get $args -testlist] - dict unset args -testlist - - - set debug [dict get $args -debug] - - set collate [dict get $args -collate] - set db [dict get $args -db] - set winlike [dict get $args -winlike] - set topchars [dict get $args -topchars] - - - puts stderr "|test>-----start natsort::$test--- input list size : [llength $argtestlist]" - #set resultlist [$test $argtestlist -db $db -collate $collate -topchars $topchars -winlike $winlike] - set resultlist [$test $argtestlist {*}$args] - foreach nm $resultlist { - puts stdout $nm - } - puts stdout "|test>-----end natsort::$test--- sorted list size: [llength $resultlist]" - return "test end" - } - proc commandline_runtests {runtests args} { - set argvals [check_flags -caller commandline_runtests \ - -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits "\uFFFF" -runtests 1] \ - -values $args] - - puts stderr "runtests args: $argvals" - - #set runtests [dict get $argvals -runtests] - dict unset argvals -runtests - dict unset argvals -algorithm - - puts stderr "runtests args: $argvals" - #exit 0 - - set test_prefix "::natsort::test_sort_" - - if {$runtests eq "1"} { - set runtests "*" - } - - - set testcommands [info commands ${test_prefix}${runtests}] - if {![llength $testcommands]} { - puts stderr "No test commands matched -runtests argument '$runtests'" - puts stderr "Use 1 to run all tests" - set alltests [info commands ${test_prefix}*] - puts stderr "Valid tests are:" - - set prefixlen [string length $test_prefix] - foreach t $alltests { - set shortname [string range $t $prefixlen end] - puts stderr "$t = -runtests $shortname" - } - - } else { - foreach cmd $testcommands { - puts stderr [string repeat - 40] - puts stderr "calling $cmd with args: '$argvals'" - puts stderr [string repeat - 40] - $cmd {*}$argvals - } - } - exit 0 - } - proc help {args} { - puts stdout "natsort::help got '$args'" - return "Help not implemented" - } - proc natsort_pipe {args} { - #PIPELINE to take input list on stdin and write sorted list to stdout - #strip - from arglist - #set args [check_flags -caller natsort_pipeline \ - # -return all \ - # -defaults [list -db :memory: -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ - # -values $args] - - - set debug [dict get $args -debug] - if {$debug} { - puts stderr "|debug> natsort_pipe got args:'$args'" - } - set algorithm [dict get $args -algorithm] - dict unset args -algorithm - - set proclist [info commands ::natsort::sort*] - set algos [list] - foreach p $proclist { - lappend algos [namespace tail $p] - } - if {$algorithm ni [list {*}$proclist {*}$algos]} { - do_error "valid sort mechanisms: $algos" 2 - } - - - set input_list [list] - while {![eof stdin]} { - if {[gets stdin line] > 0} { - lappend input_list $line - } else { - if {[eof stdin]} { - - } else { - after 10 - } - } - } - - if {$debug} { - puts stderr "|debug> received [llength $input_list] list elements" - } - - set resultlist [$algorithm $input_list {*}$args] - if {$debug} { - puts stderr "|debug> returning [llength $resultlist] list elements" - } - foreach r $resultlist { - puts stdout $r - } - #exit 0 - - } - if {($is_called_directly)} { - set cmdprocessors { - {helpfinal {match "^help$" dispatch natsort::help}} - {helpfinal {sub -topic default "NONE"}} - } - #set args [check_flags \ - # -caller test1 \ - # -debugargs 2 \ - # -return arglist \ - # -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ - # -required {none} \ - # -extras {all} \ - # -commandprocessors $cmdprocessors \ - # -values $::argv ] - interp alias {} do_filter {} ::flagfilter::check_flags - - #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld - set cmdprocessors { - {helpcmd {match "^help$" dispatch natsort::help singleopts {-v}}} - {helpcmd {sub -operand default \uFFFF singleopts {-l}}} - {lscmd {match "^ls$" dispatch natsort::commandline_ls dispatchtype tcl dispatchglobal 1 mashopts {-l -a} singleopts {-l -a} pairopts {} longopts {--color=always}}} - {lscmd {sub dir default "\uFFFF"}} - {lscmd {sub dir2 default "\uFFFF"}} - {lscmd {sub dir3 default "\uFFFF"}} - {lscmd {sub dir4 default "\uFFFF"}} - {lscmd {sub dir5 default "\uFFFF"}} - {lscmd {sub dir6 default "\uFFFF"}} - {runtests {match "^-tests$" dispatch natsort::commandline_runtests singleopts {-l}}} - {runtests {sub testname default "1" singleopts {-l}}} - {pipecmd {match "^-$" dispatch natsort::natsort_pipe dispatchtype tcl}} - } - set arglist [do_filter \ - -debugargs 0 \ - -debugargsonerror 2 \ - -caller cline_dispatch1 \ - -return all \ - -soloflags {-v -x} \ - -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \ - -required {all} \ - -extras {all} \ - -commandprocessors $cmdprocessors \ - -values $::argv ] - - - #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld - set cmdprocessors { - {testcmd {match "^test$" dispatch natsort::commandline_test singleopts {-l}}} - {testcmd {sub testname default "1" singleopts {-l}}} - } - set arglist [check_flags \ - -debugargs 0 \ - -caller cline_dispatch2 \ - -return all \ - -soloflags {-v -l} \ - -defaults [list -collate nocase -algorithm sort -testlist "1 2 3 10" -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \ - -required {all} \ - -extras {all} \ - -commandprocessors $cmdprocessors \ - -values $::argv ] - - - - - #set cmdprocessors [list] - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors $cmdprocessors -values $::argv ] - - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {-cmd {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {{-cmd -default help} {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {ls {ls lsdir -default "\uFFFF"}} -values $::argv ] - - exit 0 - - if {$::argc} { - - } - } -} - - -package provide natsort [namespace eval natsort { - variable version - set version 0.1.1.5 -}] - - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm index 4107b8af..ca061a7c 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm @@ -1,645 +1,645 @@ -package provide patterncmd [namespace eval patterncmd { - variable version - - set version 1.2.4 -}] - - -namespace eval pattern { - variable idCounter 1 ;#used by pattern::uniqueKey - - namespace eval cmd { - namespace eval util { - package require overtype - variable colwidths_lib [dict create] - variable colwidths_lib_default 15 - - dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] - dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] - dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] - dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] - - proc colhead {type args} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname [string totitle $colname] {*}$args]" - } - return $line - } - proc colbreak {type} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" - } - return $line - } - proc col {type col val args} { - # args -head bool -tail bool ? - #---------------------------------------------------------------------------- - set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] - dict set default -backchar "" - dict set default -headchar "" - dict set default -tailchar "" - dict set default -headoverridechar "" - dict set default -tailoverridechar "" - dict set default -justify "left" - if {([llength $args] % 2) != 0} { - error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " - } - foreach {k v} $args { - if {$k ni $known_opts} { - error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" - } - } - set opts [dict merge $default $args] - set backchar [dict get $opts -backchar] - set headchar [dict get $opts -headchar] - set tailchar [dict get $opts -tailchar] - set headoverridechar [dict get $opts -headoverridechar] - set tailoverridechar [dict get $opts -tailoverridechar] - set justify [dict get $opts -justify] - #---------------------------------------------------------------------------- - - - - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - #calculate headwidths - set headwidth 0 - set tailwidth 0 - foreach {key def} $colwidths { - set thisheadlen [string length [dict get $def head]] - if {$thisheadlen > $headwidth} { - set headwidth $thisheadlen - } - set thistaillen [string length [dict get $def tail]] - if {$thistaillen > $tailwidth} { - set tailwidth $thistaillen - } - } - - - set spec [dict get $colwidths $col] - if {[string length $backchar]} { - set ch $backchar - } else { - set ch [dict get $spec ch] - } - set num [dict get $spec num] - set headchar [dict get $spec head] - set tailchar [dict get $spec tail] - - if {[string length $headchar]} { - set headchar $headchar - } - if {[string length $tailchar]} { - set tailchar $tailchar - } - #overrides only apply if the head/tail has a length - if {[string length $headchar]} { - if {[string length $headoverridechar]} { - set headchar $headoverridechar - } - } - if {[string length $tailchar]} { - if {[string length $tailoverridechar]} { - set tailchar $tailoverridechar - } - } - set head [string repeat $headchar $headwidth] - set tail [string repeat $tailchar $tailwidth] - - set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] - if {$justify eq "left"} { - set left_done [overtype::left $base "$head$val"] - return [overtype::right $left_done "$tail"] - } elseif {$justify in {centre center}} { - set mid_done [overtype::centre $base $val] - set left_mid_done [overtype::left $mid_done $head] - return [overtype::right $left_mid_done $tail] - } else { - set right_done [overtype::right $base "$val$tail"] - return [overtype::left $right_done $head] - } - - } - - } - } - -} - -#package require pattern - -proc ::pattern::libs {} { - set libs [list \ - pattern {-type core -note "alternative:pattern2"}\ - pattern2 {-type core -note "alternative:pattern"}\ - patterncmd {-type core}\ - metaface {-type core}\ - patternpredator2 {-type core}\ - patterndispatcher {-type core}\ - patternlib {-type core}\ - patterncipher {-type optional -note optional}\ - ] - - - - package require overtype - set result "" - - append result "[cmd::util::colbreak lib]\n" - append result "[cmd::util::colhead lib -justify centre]\n" - append result "[cmd::util::colbreak lib]\n" - foreach libname [dict keys $libs] { - set libinfo [dict get $libs $libname] - - append result [cmd::util::col lib library $libname] - if {[catch [list package present $libname] ver]} { - append result [cmd::util::col lib version "N/A"] - } else { - append result [cmd::util::col lib version $ver] - } - append result [cmd::util::col lib type [dict get $libinfo -type]] - - if {[dict exists $libinfo -note]} { - set note [dict get $libinfo -note] - } else { - set note "" - } - append result [cmd::util::col lib note $note] - append result "\n" - } - append result "[cmd::util::colbreak lib]\n" - return $result -} - -proc ::pattern::record {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply { - {index rec args} - { - if {[llength $args] == 0} { - return [lindex $rec $index] - } - if {[llength $args] == 1} { - return [lreplace $rec $index $index [lindex $args 0]] - } - error "Invalid number of arguments." - } - - }] - - set map {} - foreach field $fields { - dict set map $field [linsert $accessor end [incr index]] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} -proc ::pattern::record2 {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply] - - set template { - {rec args} - { - if {[llength $args] == 0} { - return [lindex $rec %idx%] - } - if {[llength $args] == 1} { - return [lreplace $rec %idx% %idx% [lindex $args 0]] - } - error "Invalid number of arguments." - } - } - - set map {} - foreach field $fields { - set body [string map [list %idx% [incr index]] $template] - dict set map $field [list ::apply $body] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} - -proc ::argstest {args} { - package require cmdline - -} - -proc ::pattern::objects {} { - set result [::list] - - foreach ns [namespace children ::pp] { - #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] - set ch [namespace tail $ns] - if {[string range $ch 0 2] eq "Obj"} { - set OID [string range $ch 3 end] ;#OID need not be digits (!?) - lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] - } - } - - - - - return $result -} - - - -proc ::pattern::name {num} { - #!todo - fix - #set ::p::${num}::(self) - - lassign [interp alias {} ::p::$num] _predator info - if {![string length $_predator$info]} { - error "No object found for num:$num (no interp alias for ::p::$num)" - } - set invocants [dict get $info i] - set invocants_with_role_this [dict get $invocants this] - set invocant_this [lindex $invocants_with_role_this 0] - - - #lassign $invocant_this id info - #set map [dict get $info map] - #set fields [lindex $map 0] - lassign $invocant_this _id _ns _defaultmethod name _etc - return $name -} - - -proc ::pattern::with {cmd script} { - foreach c [info commands ::p::-1::*] { - interp alias {} [namespace tail $c] {} $c $cmd - } - interp alias {} . {} $cmd . - interp alias {} .. {} $cmd .. - - return [uplevel 1 $script] -} - - - - - -#system diagnostics etc - -proc ::pattern::varspace_list {IID} { - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables - - set varspaces [list] - dict for {vname vdef} $o_variables { - set vs [dict get $vdef varspace] - if {$vs ni $varspaces} { - lappend varspaces $vs - } - } - if {$o_varspace ni $varspaces} { - lappend varspaces $o_varspace - } - return $varspaces -} - -proc ::pattern::check_interfaces {} { - foreach ns [namespace children ::p] { - set IID [namespace tail $ns] - if {[string is digit $IID]} { - foreach ref [array names ${ns}::_iface::o_usedby] { - set OID [string range $ref 1 end] - if {![namespace exists ::p::${OID}::_iface]} { - puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" - } else { - puts -nonewline stdout . - } - - - #if {![info exists ::p::${OID}::(self)]} { - # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" - #} - } - } - } - puts -nonewline stdout "\r\n" -} - - -#from: http://wiki.tcl.tk/8766 (Introspection on aliases) -#usedby: metaface-1.1.6+ -#required because aliases can be renamed. -#A renamed alias will still return it's target with 'interp alias {} oldname' -# - so given newname - we require which_alias to return the same info. - proc ::pattern::which_alias {cmd} { - uplevel 1 [list ::trace add execution $cmd enterstep ::error] - catch {uplevel 1 $cmd} res - uplevel 1 [list ::trace remove execution $cmd enterstep ::error] - #puts stdout "which_alias $cmd returning '$res'" - return $res - } -# [info args] like proc following an alias recursivly until it reaches -# the proc it originates from or cannot determine it. -# accounts for default parameters set by interp alias -# - - - -proc ::pattern::aliasargs {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info args $cmd] - # strip off the interp set default args - return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } -proc ::pattern::aliasbody {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info body $cmd] - # strip off the interp set default args - return $result - #return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } - - - - - -proc ::pattern::uniqueKey2 {} { - #!todo - something else?? - return [clock seconds]-[incr ::pattern::idCounter] -} - -#used by patternlib package -proc ::pattern::uniqueKey {} { - return [incr ::pattern::idCounter] - #uuid with tcllibc is about 30us compared with 2us - # for large datasets, e.g about 100K inserts this would be pretty noticable! - #!todo - uuid pool with background thread to repopulate when idle? - #return [uuid::uuid generate] -} - - - -#------------------------------------------------------------------------------------------------------------------------- - -proc ::pattern::test1 {} { - set msg "OK" - - puts stderr "next line should say:'--- saystuff:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternMethod saystuff args { - puts stderr "--- saystuff: $args" - } - ::>thing .. Create ::>jjj - - ::>jjj . saystuff $msg - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test2 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternProperty stuff $msg - - ::>thing .. Create ::>jjj - - puts stderr "--- property 'stuff' value:[::>jjj . stuff]" - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test3 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. Property stuff $msg - - puts stderr "--- property 'stuff' value:[::>thing . stuff]" - ::>thing .. Destroy -} - -#--------------------------------- -#unknown/obsolete - - - - - - - - -#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} -if {0} { - proc ::p::internals::new_interface {{usedbylist {}}} { - set OID [incr ::p::ID] - ::p::internals::new_object ::p::ifaces::>$OID "" $OID - puts "obsolete >> new_interface created object $OID" - foreach usedby $usedbylist { - set ::p::${OID}::_iface::o_usedby(i$usedby) 1 - } - set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) - #NOTE - o_varspace is only the default varspace for when new methods/properties are added. - # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. - - set ::p::${OID}::_iface::o_constructor [list] - set ::p::${OID}::_iface::o_variables [list] - set ::p::${OID}::_iface::o_properties [dict create] - set ::p::${OID}::_iface::o_methods [dict create] - array set ::p::${OID}::_iface::o_definition [list] - set ::p::${OID}::_iface::o_open 1 ;#open for extending - return $OID - } - - - #temporary way to get OID - assumes single 'this' invocant - #!todo - make generic. - proc ::pattern::get_oid {_ID_} { - #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" - return [lindex [dict get $_ID_ i this] 0 0] - - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - #set role_members [dict get $invocants this] - ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. - #set this_invocant [lindex [dict get $_ID_ i this] 0] ; - #lassign $this_invocant OID this_info - # - #return $OID - } - - #compile the uncompiled level1 interface - #assert: no more than one uncompiled interface present at level1 - proc ::p::meta::PatternCompile {self} { - ???? - - upvar #0 $self SELFMAP - set ID [lindex $SELFMAP 0 0] - - set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces - - set iid -1 - foreach i $patterns { - if {[set ::p::${i}::_iface::o_open]} { - set iid $i ;#found it - break - } - } - - if {$iid > -1} { - #!todo - - ::p::compile_interface $iid - set ::p::${iid}::_iface::o_open 0 - } else { - #no uncompiled interface present at level 1. Do nothing. - return - } - } - - - proc ::p::meta::Def {self} { - error ::p::meta::Def - - upvar #0 $self SELFMAP - set self_ID [lindex $SELFMAP 0 0] - set IFID [lindex $SELFMAP 1 0 end] - - set maxc1 0 - set maxc2 0 - - set arrName ::p::${IFID}:: - - upvar #0 $arrName state - - array set methods {} - - foreach nm [array names state] { - if {[regexp {^m-1,name,(.+)} $nm _match mname]} { - set methods($mname) [set state($nm)] - - if {[string length $mname] > $maxc1} { - set maxc1 [string length $mname] - } - if {[string length [set state($nm)]] > $maxc2} { - set maxc2 [string length [set state($nm)]] - } - } - } - set bg1 [string repeat " " [expr {$maxc1 + 2}]] - set bg2 [string repeat " " [expr {$maxc2 + 2}]] - - - set r {} - foreach nm [lsort -dictionary [array names methods]] { - set arglist $state(m-1,args,$nm) - append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" - } - return $r - } - - - +package provide patterncmd [namespace eval patterncmd { + variable version + + set version 1.2.4 +}] + + +namespace eval pattern { + variable idCounter 1 ;#used by pattern::uniqueKey + + namespace eval cmd { + namespace eval util { + package require overtype + variable colwidths_lib [dict create] + variable colwidths_lib_default 15 + + dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] + dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] + dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] + dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] + + proc colhead {type args} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname [string totitle $colname] {*}$args]" + } + return $line + } + proc colbreak {type} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" + } + return $line + } + proc col {type col val args} { + # args -head bool -tail bool ? + #---------------------------------------------------------------------------- + set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] + dict set default -backchar "" + dict set default -headchar "" + dict set default -tailchar "" + dict set default -headoverridechar "" + dict set default -tailoverridechar "" + dict set default -justify "left" + if {([llength $args] % 2) != 0} { + error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set backchar [dict get $opts -backchar] + set headchar [dict get $opts -headchar] + set tailchar [dict get $opts -tailchar] + set headoverridechar [dict get $opts -headoverridechar] + set tailoverridechar [dict get $opts -tailoverridechar] + set justify [dict get $opts -justify] + #---------------------------------------------------------------------------- + + + + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + #calculate headwidths + set headwidth 0 + set tailwidth 0 + foreach {key def} $colwidths { + set thisheadlen [string length [dict get $def head]] + if {$thisheadlen > $headwidth} { + set headwidth $thisheadlen + } + set thistaillen [string length [dict get $def tail]] + if {$thistaillen > $tailwidth} { + set tailwidth $thistaillen + } + } + + + set spec [dict get $colwidths $col] + if {[string length $backchar]} { + set ch $backchar + } else { + set ch [dict get $spec ch] + } + set num [dict get $spec num] + set headchar [dict get $spec head] + set tailchar [dict get $spec tail] + + if {[string length $headchar]} { + set headchar $headchar + } + if {[string length $tailchar]} { + set tailchar $tailchar + } + #overrides only apply if the head/tail has a length + if {[string length $headchar]} { + if {[string length $headoverridechar]} { + set headchar $headoverridechar + } + } + if {[string length $tailchar]} { + if {[string length $tailoverridechar]} { + set tailchar $tailoverridechar + } + } + set head [string repeat $headchar $headwidth] + set tail [string repeat $tailchar $tailwidth] + + set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] + if {$justify eq "left"} { + set left_done [overtype::left $base "$head$val"] + return [overtype::right $left_done "$tail"] + } elseif {$justify in {centre center}} { + set mid_done [overtype::centre $base $val] + set left_mid_done [overtype::left $mid_done $head] + return [overtype::right $left_mid_done $tail] + } else { + set right_done [overtype::right $base "$val$tail"] + return [overtype::left $right_done $head] + } + + } + + } + } + +} + +#package require pattern + +proc ::pattern::libs {} { + set libs [list \ + pattern {-type core -note "alternative:pattern2"}\ + pattern2 {-type core -note "alternative:pattern"}\ + patterncmd {-type core}\ + metaface {-type core}\ + patternpredator2 {-type core}\ + patterndispatcher {-type core}\ + patternlib {-type core}\ + patterncipher {-type optional -note optional}\ + ] + + + + package require overtype + set result "" + + append result "[cmd::util::colbreak lib]\n" + append result "[cmd::util::colhead lib -justify centre]\n" + append result "[cmd::util::colbreak lib]\n" + foreach libname [dict keys $libs] { + set libinfo [dict get $libs $libname] + + append result [cmd::util::col lib library $libname] + if {[catch [list package present $libname] ver]} { + append result [cmd::util::col lib version "N/A"] + } else { + append result [cmd::util::col lib version $ver] + } + append result [cmd::util::col lib type [dict get $libinfo -type]] + + if {[dict exists $libinfo -note]} { + set note [dict get $libinfo -note] + } else { + set note "" + } + append result [cmd::util::col lib note $note] + append result "\n" + } + append result "[cmd::util::colbreak lib]\n" + return $result +} + +proc ::pattern::record {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply { + {index rec args} + { + if {[llength $args] == 0} { + return [lindex $rec $index] + } + if {[llength $args] == 1} { + return [lreplace $rec $index $index [lindex $args 0]] + } + error "Invalid number of arguments." + } + + }] + + set map {} + foreach field $fields { + dict set map $field [linsert $accessor end [incr index]] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} +proc ::pattern::record2 {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply] + + set template { + {rec args} + { + if {[llength $args] == 0} { + return [lindex $rec %idx%] + } + if {[llength $args] == 1} { + return [lreplace $rec %idx% %idx% [lindex $args 0]] + } + error "Invalid number of arguments." + } + } + + set map {} + foreach field $fields { + set body [string map [list %idx% [incr index]] $template] + dict set map $field [list ::apply $body] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} + +proc ::argstest {args} { + package require cmdline + +} + +proc ::pattern::objects {} { + set result [::list] + + foreach ns [namespace children ::pp] { + #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] + set ch [namespace tail $ns] + if {[string range $ch 0 2] eq "Obj"} { + set OID [string range $ch 3 end] ;#OID need not be digits (!?) + lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] + } + } + + + + + return $result +} + + + +proc ::pattern::name {num} { + #!todo - fix + #set ::p::${num}::(self) + + lassign [interp alias {} ::p::$num] _predator info + if {![string length $_predator$info]} { + error "No object found for num:$num (no interp alias for ::p::$num)" + } + set invocants [dict get $info i] + set invocants_with_role_this [dict get $invocants this] + set invocant_this [lindex $invocants_with_role_this 0] + + + #lassign $invocant_this id info + #set map [dict get $info map] + #set fields [lindex $map 0] + lassign $invocant_this _id _ns _defaultmethod name _etc + return $name +} + + +proc ::pattern::with {cmd script} { + foreach c [info commands ::p::-1::*] { + interp alias {} [namespace tail $c] {} $c $cmd + } + interp alias {} . {} $cmd . + interp alias {} .. {} $cmd .. + + return [uplevel 1 $script] +} + + + + + +#system diagnostics etc + +proc ::pattern::varspace_list {IID} { + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables + + set varspaces [list] + dict for {vname vdef} $o_variables { + set vs [dict get $vdef varspace] + if {$vs ni $varspaces} { + lappend varspaces $vs + } + } + if {$o_varspace ni $varspaces} { + lappend varspaces $o_varspace + } + return $varspaces +} + +proc ::pattern::check_interfaces {} { + foreach ns [namespace children ::p] { + set IID [namespace tail $ns] + if {[string is digit $IID]} { + foreach ref [array names ${ns}::_iface::o_usedby] { + set OID [string range $ref 1 end] + if {![namespace exists ::p::${OID}::_iface]} { + puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" + } else { + puts -nonewline stdout . + } + + + #if {![info exists ::p::${OID}::(self)]} { + # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" + #} + } + } + } + puts -nonewline stdout "\r\n" +} + + +#from: http://wiki.tcl.tk/8766 (Introspection on aliases) +#usedby: metaface-1.1.6+ +#required because aliases can be renamed. +#A renamed alias will still return it's target with 'interp alias {} oldname' +# - so given newname - we require which_alias to return the same info. + proc ::pattern::which_alias {cmd} { + uplevel 1 [list ::trace add execution $cmd enterstep ::error] + catch {uplevel 1 $cmd} res + uplevel 1 [list ::trace remove execution $cmd enterstep ::error] + #puts stdout "which_alias $cmd returning '$res'" + return $res + } +# [info args] like proc following an alias recursivly until it reaches +# the proc it originates from or cannot determine it. +# accounts for default parameters set by interp alias +# + + + +proc ::pattern::aliasargs {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info args $cmd] + # strip off the interp set default args + return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } + } +proc ::pattern::aliasbody {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info body $cmd] + # strip off the interp set default args + return $result + #return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } + } + + + + + +proc ::pattern::uniqueKey2 {} { + #!todo - something else?? + return [clock seconds]-[incr ::pattern::idCounter] +} + +#used by patternlib package +proc ::pattern::uniqueKey {} { + return [incr ::pattern::idCounter] + #uuid with tcllibc is about 30us compared with 2us + # for large datasets, e.g about 100K inserts this would be pretty noticable! + #!todo - uuid pool with background thread to repopulate when idle? + #return [uuid::uuid generate] +} + + + +#------------------------------------------------------------------------------------------------------------------------- + +proc ::pattern::test1 {} { + set msg "OK" + + puts stderr "next line should say:'--- saystuff:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternMethod saystuff args { + puts stderr "--- saystuff: $args" + } + ::>thing .. Create ::>jjj + + ::>jjj . saystuff $msg + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test2 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternProperty stuff $msg + + ::>thing .. Create ::>jjj + + puts stderr "--- property 'stuff' value:[::>jjj . stuff]" + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test3 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. Property stuff $msg + + puts stderr "--- property 'stuff' value:[::>thing . stuff]" + ::>thing .. Destroy +} + +#--------------------------------- +#unknown/obsolete + + + + + + + + +#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} +if {0} { + proc ::p::internals::new_interface {{usedbylist {}}} { + set OID [incr ::p::ID] + ::p::internals::new_object ::p::ifaces::>$OID "" $OID + puts "obsolete >> new_interface created object $OID" + foreach usedby $usedbylist { + set ::p::${OID}::_iface::o_usedby(i$usedby) 1 + } + set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) + #NOTE - o_varspace is only the default varspace for when new methods/properties are added. + # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. + + set ::p::${OID}::_iface::o_constructor [list] + set ::p::${OID}::_iface::o_variables [list] + set ::p::${OID}::_iface::o_properties [dict create] + set ::p::${OID}::_iface::o_methods [dict create] + array set ::p::${OID}::_iface::o_definition [list] + set ::p::${OID}::_iface::o_open 1 ;#open for extending + return $OID + } + + + #temporary way to get OID - assumes single 'this' invocant + #!todo - make generic. + proc ::pattern::get_oid {_ID_} { + #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" + return [lindex [dict get $_ID_ i this] 0 0] + + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + #set role_members [dict get $invocants this] + ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. + #set this_invocant [lindex [dict get $_ID_ i this] 0] ; + #lassign $this_invocant OID this_info + # + #return $OID + } + + #compile the uncompiled level1 interface + #assert: no more than one uncompiled interface present at level1 + proc ::p::meta::PatternCompile {self} { + ???? + + upvar #0 $self SELFMAP + set ID [lindex $SELFMAP 0 0] + + set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces + + set iid -1 + foreach i $patterns { + if {[set ::p::${i}::_iface::o_open]} { + set iid $i ;#found it + break + } + } + + if {$iid > -1} { + #!todo + + ::p::compile_interface $iid + set ::p::${iid}::_iface::o_open 0 + } else { + #no uncompiled interface present at level 1. Do nothing. + return + } + } + + + proc ::p::meta::Def {self} { + error ::p::meta::Def + + upvar #0 $self SELFMAP + set self_ID [lindex $SELFMAP 0 0] + set IFID [lindex $SELFMAP 1 0 end] + + set maxc1 0 + set maxc2 0 + + set arrName ::p::${IFID}:: + + upvar #0 $arrName state + + array set methods {} + + foreach nm [array names state] { + if {[regexp {^m-1,name,(.+)} $nm _match mname]} { + set methods($mname) [set state($nm)] + + if {[string length $mname] > $maxc1} { + set maxc1 [string length $mname] + } + if {[string length [set state($nm)]] > $maxc2} { + set maxc2 [string length [set state($nm)]] + } + } + } + set bg1 [string repeat " " [expr {$maxc1 + 2}]] + set bg2 [string repeat " " [expr {$maxc2 + 2}]] + + + set r {} + foreach nm [lsort -dictionary [array names methods]] { + set arglist $state(m-1,args,$nm) + append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" + } + return $r + } + + + } \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm index 457d5742..680ea88f 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm @@ -1,754 +1,754 @@ -package provide patternpredator2 1.2.4 - -proc ::p::internals::jaws {OID _ID_ args} { - #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" - #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - yield - set w 1 - - set stack [list] - set wordcount [llength $args] - set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first - set unsupported 0 - set operator "" - set operator_prev "" ;#used only by argprotect to revert to previous operator - - - if {$OID ne "null"} { - #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) - #upvar #0 ::p::${OID}::_meta::map MAP - set MAP [set ::p::${OID}::_meta::map] - } else { - # error "jaws - OID = 'null' ???" - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key - } - set invocantdata [dict get $MAP invocantdata] - lassign $invocantdata OID alias default_method object_command wrapped - - set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code - - #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w - while {$w < $wordcount} { - set word [lindex $args [expr {$w -1}]] - #puts stdout "w:$w word:$word stack:$stack" - - if {$operator eq "argprotect"} { - set operator $operator_prev - lappend stack $word - incr w - } else { - if {[llength $stack]} { - if {$word in $terminals} { - set reduction [list 0 $_ID_ {*}$stack ] - #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" - - - set _ID_ [yield $reduction] - set stack [list] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] - #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" - } - - #review - 2018. switched to _ID_ instead of MAP - lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command - #lassign [dict get $MAP invocantdata] OID alias default_method object_command - - - #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" - set operator $word - #don't incr w - #incr w - } else { - if {$operator eq "argprotect"} { - set operator $operator_prev - set operator_prev "" - lappend stack $word - } else { - #only look for leading argprotect chacter (-) if we're not already in argprotect mode - if {$word eq "--"} { - set operator_prev $operator - set operator "argprotect" - #Don't add the plain argprotector to the stack - } elseif {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set operator_prev $operator - set operator "argprotect" - lappend stack $word - } else { - lappend stack $word - } - } - - - incr w - } - } else { - #no stack - switch -- $word {.} { - - if {$OID ne "null"} { - #we know next word is a property or method of a pattern object - incr w - set nextword [lindex $args [expr {$w - 1}]] - set command ::p::${OID}::$nextword - set stack [list $command] ;#2018 j - set operator . - if {$w eq $wordcount} { - set finished_args 1 - } - } else { - # don't incr w - #set nextword [lindex $args [expr {$w - 1}]] - set command $object_command ;#taken from the MAP - set stack [list "_exec_" $command] - set operator . - } - - - } {..} { - incr w - set nextword [lindex $args [expr {$w -1}]] - set command ::p::-1::$nextword - #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. - set stack [list $command] ;#faster, and intent is clearer than lappend. - set operator .. - if {$w eq $wordcount} { - set finished_args 1 - } - } {,} { - #puts stdout "Stackless comma!" - - - if {$OID ne "null"} { - set command ::p::${OID}::$default_method - } else { - set command [list $default_method $object_command] - #object_command in this instance presumably be a list and $default_method a list operation - #e.g "lindex {A B C}" - } - #lappend stack $command - set stack [list $command] - set operator , - } {--} { - set operator_prev $operator - set operator argprotect - #no stack - - } {!} { - set command $object_command - set stack [list "_exec_" $object_command] - #puts stdout "!!!! !!!! $stack" - set operator ! - } default { - if {$operator eq ""} { - if {$OID ne "null"} { - set command ::p::${OID}::$default_method - } else { - set command [list $default_method $object_command] - } - set stack [list $command] - set operator , - lappend stack $word - } else { - #no stack - so we don't expect to be in argprotect mode already. - if {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set operator_prev $operator - set operator "argprotect" - lappend stack $word - } else { - lappend stack $word - } - - } - } - incr w - } - - } - } ;#end while - - #process final word outside of loop - #assert $w == $wordcount - #trailing operators or last argument - if {!$finished_args} { - set word [lindex $args [expr {$w -1}]] - if {$operator eq "argprotect"} { - set operator $operator_prev - set operator_prev "" - - lappend stack $word - incr w - } else { - - - switch -- $word {.} { - if {![llength $stack]} { - #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] - yieldto return [::p::internals::ref_to_object $_ID_] - error "assert: never gets here" - - } else { - #puts stdout "==== $stack" - #assert - whenever _ID_ changed in this proc - we have updated the $OID variable - yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] - error "assert: never gets here" - } - set operator . - - } {..} { - #trailing .. after chained call e.g >x . item 0 .. - #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" - #set reduction [list 0 $_ID_ {*}$stack] - yieldto return [yield [list 0 $_ID_ {*}$stack]] - } {#} { - set unsupported 1 - } {,} { - set unsupported 1 - } {&} { - set unsupported 1 - } {@} { - set unsupported 1 - } {--} { - - #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] - #puts stdout " -> -> -> about to call yield $reduction <- <- <-" - set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] - } - yieldto return $MAP - } {!} { - #error "untested branch" - set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] - } - lassign [dict get $MAP invocantdata] OID alias default_command object_command - set command $object_command - set stack [list "_exec_" $command] - set operator ! - } default { - if {$operator eq ""} { - #error "untested branch" - lassign [dict get $MAP invocantdata] OID alias default_command object_command - #set command ::p::${OID}::item - set command ::p::${OID}::$default_command - lappend stack $command - set operator , - - } - #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. - lappend stack $word - } - if {$unsupported} { - set unsupported 0 - error "trailing '$word' not supported" - - } - - #if {$operator eq ","} { - # incr wordcount 2 - # set stack [linsert $stack end-1 . item] - #} - incr w - } - } - - - #final = 1 - #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" - - return [list 1 $_ID_ {*}$stack] -} - - - -#trailing. directly after object -proc ::p::internals::ref_to_object {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_method object_command - set refname ::p::${OID}::_ref::__OBJECT - - array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces - - set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" - trace add variable $refname {read} $traceCmd - } - set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] - if {[list {array} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {array} $traceCmd - } - - set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] - if {[list {write} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {write} $traceCmd - } - - set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] - if {[list {unset} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {unset} $traceCmd - } - return $refname -} - - -proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { - #if {[lindex $fullstack 0] eq "_exec_"} { - # #strip it. This instruction isn't relevant for a reference. - # set commandstack [lrange $fullstack 1 end] - #} else { - # set commandstack $fullstack - #} - #set argstack [lassign $commandstack command] - #set field [string map {> __OBJECT_} [namespace tail $command]] - - - - set reftail [namespace tail $refname] - set argstack [lassign [split $reftail +] field] - set field [string map {> __OBJECT_} [namespace tail $command]] - - #puts stderr "refname:'$refname' command: $command field:$field" - - - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - } else { - #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] - } - lassign [dict get $MAP invocantdata] OID alias default_method object_command - - - - if {$OID ne "null"} { - interp alias {} $refname {} $command $_ID_ {*}$argstack - } else { - interp alias {} $refname {} $command {*}$argstack - } - - - #set iflist [lindex $map 1 0] - set iflist [dict get $MAP interfaces level0] - #set iflist [dict get $MAP interfaces level0] - set field_is_property_like 0 - foreach IFID [lreverse $iflist] { - #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. - if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { - set field_is_property_like 1 - #There is a setter or getter (but not necessarily an entry in the o_properties dict) - break - } - } - - - - - #whether field is a property or a method - remove any commandrefMisuse_TraceHandler - foreach tinfo [trace info variable $refname] { - #puts "-->removing traces on $refname: $tinfo" - if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { - trace remove variable $refname {*}$tinfo - } - } - - if {$field_is_property_like} { - #property reference - - - set this_invocantdata [lindex [dict get $_ID_ i this] 0] - lassign $this_invocantdata OID _alias _defaultmethod object_command - #get fully qualified varspace - - # - set propdict [$object_command .. GetPropertyInfo $field] - if {[dict exist $propdict $field]} { - set field_is_a_property 1 - set propinfo [dict get $propdict $field] - set varspace [dict get $propinfo varspace] - if {$varspace eq ""} { - set full_varspace ::p::${OID} - } else { - if {[::string match "::*" $varspace]} { - set full_varspace $varspace - } else { - set full_varspace ::p::${OID}::$varspace - } - } - } else { - set field_is_a_property 0 - #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property - #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) - set full_varspace ::p::${OID} - } - - - - - - #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) - set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] - if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { - trace add variable ${full_varspace}::o_${field} {write} $Hndlr - } - set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] - if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { - trace add variable ${full_varspace}::o_${field} {unset} $Hndlr - } - - - #supply all data in easy-access form so that propref_trace_read is not doing any extra work. - set get_cmd ::p::${OID}::(GET)$field - set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] - - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - set fieldvarname ${full_varspace}::o_${field} - - - #synch the refvar with the real var if it exists - #catch {set $refname [$refname]} - if {[array exists $fieldvarname]} { - if {![llength $argstack]} { - #unindexed reference - array set $refname [array get $fieldvarname] - #upvar $fieldvarname $refname - } else { - set s0 [lindex $argstack 0] - #refs to nonexistant array members common? (catch vs 'info exists') - if {[info exists ${fieldvarname}($s0)]} { - set $refname [set ${fieldvarname}($s0)] - } - } - } else { - #refs to uninitialised props actually should be *very* common. - #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. - #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. - - #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! - - #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" - - - if {![llength $argstack]} { - #catch {set $refname [set ::p::${OID}::o_$field]} - if {[info exists $fieldvarname]} { - set $refname [set $fieldvarname] - #upvar $fieldvarname $refname - } - } else { - if {[llength $argstack] == 1} { - #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} - if {[info exists $fieldvarname]} { - set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] - } - - } else { - #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} - if {[info exists $fieldvarname]} { - set $refname [lindex [set $fieldvarname] $argstack] - } - } - } - - #! what if someone has put a trace on ::errorInfo?? - #set ::errorInfo $errorInfo_prev - } - trace add variable $refname {read} $traceCmd - - set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] - trace add variable $refname {write} $traceCmd - - set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] - trace add variable $refname {unset} $traceCmd - - - set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] - # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" - trace add variable $refname {array} $traceCmd - } - - } else { - #puts "$refname ====> adding refMisuse_traceHandler $alias $field" - #matching variable in order to detect attempted use as property and throw error - - #2018 - #Note that we are adding a trace on a variable (the refname) which does not exist. - #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) - #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added - ##array set $refname {} ;#empty array - # - the empty array would mean a slightly better error message when misusing a command ref as an array - #but this seems like a code complication for little benefit - #review - - trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] - } -} - - - -#trailing. after command/property -proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { - if {[lindex $fullstack 0] eq "_exec_"} { - #strip it. This instruction isn't relevant for a reference. - set commandstack [lrange $fullstack 1 end] - } else { - set commandstack $fullstack - } - set argstack [lassign $commandstack command] - set field [string map {> __OBJECT_} [namespace tail $command]] - - - #!todo? - # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. - # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. - - - #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. - # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. - - - set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] - - if {[llength [info commands $refname]]} { - #todo - review - what if the field changed to/from a property/method? - #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs - return $refname - } - ::p::internals::create_or_update_reference $OID $_ID_ $refname $command - return $refname -} - - -namespace eval pp { - variable operators [list .. . -- - & @ # , !] - variable operators_notin_args "" - foreach op $operators { - append operators_notin_args "({$op} ni \$args) && " - } - set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands - #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} -} -interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! - - - - - -# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. -#each map is a 2 element list of lists. -# form: {$commandinfo $interfaceinfo} -# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} - -#2018 -#each map is a dict. -#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} - - -#OID = Object ID (integer for now - could in future be a uuid) -proc ::p::predator2 {_ID_ args} { - #puts stderr "predator2: _ID_:'$_ID_' args:'$args'" - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - - #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. - #set this_role_members [dict get $invocants this] - #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. - #lassign $this_invocant this_OID this_info_dict - - set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - - set cheat 1 ;# - #------- - #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) - #(it should be functionally equivalent to remove this shortcut block) - if {$cheat} { - if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { - - set remaining_args [lassign $args dot method_or_prop] - - #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? - set command ::p::${this_OID}::$method_or_prop - #REVIEW! - #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') - #if {[llength $command] > 1} { - # error "methods with spaces not included in test suites - todo fix!" - #} - #Dont use {*}$command - (so we can support methods with spaces) - #if {![llength [info commands $command]]} {} - if {[namespace which $command] eq ""} { - if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { - #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces - set command ::p::${this_OID}::(UNKNOWN) - #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" - } - } else { - #tailcall {*}$command $_ID_ {*}$remaining_args - tailcall $command $_ID_ {*}$remaining_args - } - } - } - #------------ - - - if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { - return $_ID_ - } - - - #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" - - - - #puts stderr "this_info_dict: $this_info_dict" - - - - - if {![llength $args]} { - #should return some sort of public info.. i.e probably not the ID which is an implementation detail - #return cmd - return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID - - #return a dict keyed on object command name - (suitable as use for a .. Create 'target') - #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped - #return [list $object_command [list -id $this_OID ]] - } elseif {[llength $args] == 1} { - #short-circuit the single index case for speed. - if {[lindex $args 0] ni {.. . -- - & @ # , !}} { - #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method - lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method - - tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] - } elseif {[lindex $args 0] eq {--}} { - - #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. - # - combined with using UUIDs for $OID, and a secured/removed metaface on the object - # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) - # - this could effectively hide the object's namespaces,vars etc from the caller (?) - return [set ::p::${this_OID}::_meta::map] - } - } - - - - #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) - #incr c - #set reduce ::p::reducer${this_OID}_$c - set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] - #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" - coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args - - - set current_ID_ $_ID_ - - set final 0 - set result "" - while {$final == 0} { - #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) - set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] - #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" - #if {[string match *Destroy $command]} { - # puts stdout " calling Destroy reduction_args:'$reduction_args'" - #} - if {$final == 1} { - - if {[llength $command] == 1} { - if {$command eq "_exec_"} { - tailcall {*}$reduction_args - } - if {[llength [info commands $command]]} { - tailcall {*}$command $current_ID_ {*}$reduction_args - } - set cmdname [namespace tail $command] - set this_OID [lindex [dict get $current_ID_ i this] 0 0] - if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { - lset command 0 ::p::${this_OID}::(UNKNOWN) - tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" - } - - } else { - #e.g lindex {a b c} - tailcall {*}$command {*}$reduction_args - } - - - } else { - if {[lindex $command 0] eq "_exec_"} { - set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] - - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] - } else { - if {[llength $command] == 1} { - if {![llength [info commands $command]]} { - set cmdname [namespace tail $command] - set this_OID [lindex [dict get $current_ID_ i this] 0 0] - if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { - - lset command 0 ::p::${this_OID}::(UNKNOWN) - set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" - } - } else { - #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] - set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] - - } - } else { - set result [uplevel 1 [list {*}$command {*}$reduction_args]] - } - - if {[llength [info commands $result]]} { - if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { - #looks like a pattern command - set current_ID_ [$result .. INVOCANTDATA] - - - #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA - #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { - # set current_ID_ $result_invocantdata - #} else { - # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" - #} - } else { - #non-pattern command - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] - } - } else { - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] - #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) - - } - } - - } - } - error "Assert: Shouldn't get here (end of ::p::predator2)" - #return $result -} +package provide patternpredator2 1.2.4 + +proc ::p::internals::jaws {OID _ID_ args} { + #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" + #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + yield + set w 1 + + set stack [list] + set wordcount [llength $args] + set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first + set unsupported 0 + set operator "" + set operator_prev "" ;#used only by argprotect to revert to previous operator + + + if {$OID ne "null"} { + #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) + #upvar #0 ::p::${OID}::_meta::map MAP + set MAP [set ::p::${OID}::_meta::map] + } else { + # error "jaws - OID = 'null' ???" + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key + } + set invocantdata [dict get $MAP invocantdata] + lassign $invocantdata OID alias default_method object_command wrapped + + set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code + + #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w + while {$w < $wordcount} { + set word [lindex $args [expr {$w -1}]] + #puts stdout "w:$w word:$word stack:$stack" + + if {$operator eq "argprotect"} { + set operator $operator_prev + lappend stack $word + incr w + } else { + if {[llength $stack]} { + if {$word in $terminals} { + set reduction [list 0 $_ID_ {*}$stack ] + #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" + + + set _ID_ [yield $reduction] + set stack [list] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] + #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" + } + + #review - 2018. switched to _ID_ instead of MAP + lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command + #lassign [dict get $MAP invocantdata] OID alias default_method object_command + + + #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" + set operator $word + #don't incr w + #incr w + } else { + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + lappend stack $word + } else { + #only look for leading argprotect chacter (-) if we're not already in argprotect mode + if {$word eq "--"} { + set operator_prev $operator + set operator "argprotect" + #Don't add the plain argprotector to the stack + } elseif {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + } + + + incr w + } + } else { + #no stack + switch -- $word {.} { + + if {$OID ne "null"} { + #we know next word is a property or method of a pattern object + incr w + set nextword [lindex $args [expr {$w - 1}]] + set command ::p::${OID}::$nextword + set stack [list $command] ;#2018 j + set operator . + if {$w eq $wordcount} { + set finished_args 1 + } + } else { + # don't incr w + #set nextword [lindex $args [expr {$w - 1}]] + set command $object_command ;#taken from the MAP + set stack [list "_exec_" $command] + set operator . + } + + + } {..} { + incr w + set nextword [lindex $args [expr {$w -1}]] + set command ::p::-1::$nextword + #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. + set stack [list $command] ;#faster, and intent is clearer than lappend. + set operator .. + if {$w eq $wordcount} { + set finished_args 1 + } + } {,} { + #puts stdout "Stackless comma!" + + + if {$OID ne "null"} { + set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + #object_command in this instance presumably be a list and $default_method a list operation + #e.g "lindex {A B C}" + } + #lappend stack $command + set stack [list $command] + set operator , + } {--} { + set operator_prev $operator + set operator argprotect + #no stack - + } {!} { + set command $object_command + set stack [list "_exec_" $object_command] + #puts stdout "!!!! !!!! $stack" + set operator ! + } default { + if {$operator eq ""} { + if {$OID ne "null"} { + set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + } + set stack [list $command] + set operator , + lappend stack $word + } else { + #no stack - so we don't expect to be in argprotect mode already. + if {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + + } + } + incr w + } + + } + } ;#end while + + #process final word outside of loop + #assert $w == $wordcount + #trailing operators or last argument + if {!$finished_args} { + set word [lindex $args [expr {$w -1}]] + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + + lappend stack $word + incr w + } else { + + + switch -- $word {.} { + if {![llength $stack]} { + #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] + yieldto return [::p::internals::ref_to_object $_ID_] + error "assert: never gets here" + + } else { + #puts stdout "==== $stack" + #assert - whenever _ID_ changed in this proc - we have updated the $OID variable + yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] + error "assert: never gets here" + } + set operator . + + } {..} { + #trailing .. after chained call e.g >x . item 0 .. + #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" + #set reduction [list 0 $_ID_ {*}$stack] + yieldto return [yield [list 0 $_ID_ {*}$stack]] + } {#} { + set unsupported 1 + } {,} { + set unsupported 1 + } {&} { + set unsupported 1 + } {@} { + set unsupported 1 + } {--} { + + #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] + #puts stdout " -> -> -> about to call yield $reduction <- <- <-" + set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] + } + yieldto return $MAP + } {!} { + #error "untested branch" + set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] + } + lassign [dict get $MAP invocantdata] OID alias default_command object_command + set command $object_command + set stack [list "_exec_" $command] + set operator ! + } default { + if {$operator eq ""} { + #error "untested branch" + lassign [dict get $MAP invocantdata] OID alias default_command object_command + #set command ::p::${OID}::item + set command ::p::${OID}::$default_command + lappend stack $command + set operator , + + } + #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. + lappend stack $word + } + if {$unsupported} { + set unsupported 0 + error "trailing '$word' not supported" + + } + + #if {$operator eq ","} { + # incr wordcount 2 + # set stack [linsert $stack end-1 . item] + #} + incr w + } + } + + + #final = 1 + #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" + + return [list 1 $_ID_ {*}$stack] +} + + + +#trailing. directly after object +proc ::p::internals::ref_to_object {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command + set refname ::p::${OID}::_ref::__OBJECT + + array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces + + set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" + trace add variable $refname {read} $traceCmd + } + set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] + if {[list {array} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {array} $traceCmd + } + + set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] + if {[list {write} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {write} $traceCmd + } + + set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] + if {[list {unset} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {unset} $traceCmd + } + return $refname +} + + +proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { + #if {[lindex $fullstack 0] eq "_exec_"} { + # #strip it. This instruction isn't relevant for a reference. + # set commandstack [lrange $fullstack 1 end] + #} else { + # set commandstack $fullstack + #} + #set argstack [lassign $commandstack command] + #set field [string map {> __OBJECT_} [namespace tail $command]] + + + + set reftail [namespace tail $refname] + set argstack [lassign [split $reftail +] field] + set field [string map {> __OBJECT_} [namespace tail $command]] + + #puts stderr "refname:'$refname' command: $command field:$field" + + + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + } else { + #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] + } + lassign [dict get $MAP invocantdata] OID alias default_method object_command + + + + if {$OID ne "null"} { + interp alias {} $refname {} $command $_ID_ {*}$argstack + } else { + interp alias {} $refname {} $command {*}$argstack + } + + + #set iflist [lindex $map 1 0] + set iflist [dict get $MAP interfaces level0] + #set iflist [dict get $MAP interfaces level0] + set field_is_property_like 0 + foreach IFID [lreverse $iflist] { + #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. + if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { + set field_is_property_like 1 + #There is a setter or getter (but not necessarily an entry in the o_properties dict) + break + } + } + + + + + #whether field is a property or a method - remove any commandrefMisuse_TraceHandler + foreach tinfo [trace info variable $refname] { + #puts "-->removing traces on $refname: $tinfo" + if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { + trace remove variable $refname {*}$tinfo + } + } + + if {$field_is_property_like} { + #property reference + + + set this_invocantdata [lindex [dict get $_ID_ i this] 0] + lassign $this_invocantdata OID _alias _defaultmethod object_command + #get fully qualified varspace + + # + set propdict [$object_command .. GetPropertyInfo $field] + if {[dict exist $propdict $field]} { + set field_is_a_property 1 + set propinfo [dict get $propdict $field] + set varspace [dict get $propinfo varspace] + if {$varspace eq ""} { + set full_varspace ::p::${OID} + } else { + if {[::string match "::*" $varspace]} { + set full_varspace $varspace + } else { + set full_varspace ::p::${OID}::$varspace + } + } + } else { + set field_is_a_property 0 + #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property + #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) + set full_varspace ::p::${OID} + } + + + + + + #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) + set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] + if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { + trace add variable ${full_varspace}::o_${field} {write} $Hndlr + } + set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] + if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { + trace add variable ${full_varspace}::o_${field} {unset} $Hndlr + } + + + #supply all data in easy-access form so that propref_trace_read is not doing any extra work. + set get_cmd ::p::${OID}::(GET)$field + set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] + + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + set fieldvarname ${full_varspace}::o_${field} + + + #synch the refvar with the real var if it exists + #catch {set $refname [$refname]} + if {[array exists $fieldvarname]} { + if {![llength $argstack]} { + #unindexed reference + array set $refname [array get $fieldvarname] + #upvar $fieldvarname $refname + } else { + set s0 [lindex $argstack 0] + #refs to nonexistant array members common? (catch vs 'info exists') + if {[info exists ${fieldvarname}($s0)]} { + set $refname [set ${fieldvarname}($s0)] + } + } + } else { + #refs to uninitialised props actually should be *very* common. + #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. + #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. + + #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! + + #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" + + + if {![llength $argstack]} { + #catch {set $refname [set ::p::${OID}::o_$field]} + if {[info exists $fieldvarname]} { + set $refname [set $fieldvarname] + #upvar $fieldvarname $refname + } + } else { + if {[llength $argstack] == 1} { + #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] + } + + } else { + #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] $argstack] + } + } + } + + #! what if someone has put a trace on ::errorInfo?? + #set ::errorInfo $errorInfo_prev + } + trace add variable $refname {read} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] + trace add variable $refname {write} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] + trace add variable $refname {unset} $traceCmd + + + set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] + # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" + trace add variable $refname {array} $traceCmd + } + + } else { + #puts "$refname ====> adding refMisuse_traceHandler $alias $field" + #matching variable in order to detect attempted use as property and throw error + + #2018 + #Note that we are adding a trace on a variable (the refname) which does not exist. + #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) + #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added + ##array set $refname {} ;#empty array + # - the empty array would mean a slightly better error message when misusing a command ref as an array + #but this seems like a code complication for little benefit + #review + + trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] + } +} + + + +#trailing. after command/property +proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { + if {[lindex $fullstack 0] eq "_exec_"} { + #strip it. This instruction isn't relevant for a reference. + set commandstack [lrange $fullstack 1 end] + } else { + set commandstack $fullstack + } + set argstack [lassign $commandstack command] + set field [string map {> __OBJECT_} [namespace tail $command]] + + + #!todo? + # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. + # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. + + + #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. + # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. + + + set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] + + if {[llength [info commands $refname]]} { + #todo - review - what if the field changed to/from a property/method? + #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs + return $refname + } + ::p::internals::create_or_update_reference $OID $_ID_ $refname $command + return $refname +} + + +namespace eval pp { + variable operators [list .. . -- - & @ # , !] + variable operators_notin_args "" + foreach op $operators { + append operators_notin_args "({$op} ni \$args) && " + } + set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands + #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} +} +interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! + + + + + +# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. +#each map is a 2 element list of lists. +# form: {$commandinfo $interfaceinfo} +# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} + +#2018 +#each map is a dict. +#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} + + +#OID = Object ID (integer for now - could in future be a uuid) +proc ::p::predator2 {_ID_ args} { + #puts stderr "predator2: _ID_:'$_ID_' args:'$args'" + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + + #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. + #set this_role_members [dict get $invocants this] + #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. + #lassign $this_invocant this_OID this_info_dict + + set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + + set cheat 1 ;# + #------- + #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) + #(it should be functionally equivalent to remove this shortcut block) + if {$cheat} { + if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { + + set remaining_args [lassign $args dot method_or_prop] + + #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? + set command ::p::${this_OID}::$method_or_prop + #REVIEW! + #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') + #if {[llength $command] > 1} { + # error "methods with spaces not included in test suites - todo fix!" + #} + #Dont use {*}$command - (so we can support methods with spaces) + #if {![llength [info commands $command]]} {} + if {[namespace which $command] eq ""} { + if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { + #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces + set command ::p::${this_OID}::(UNKNOWN) + #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" + } + } else { + #tailcall {*}$command $_ID_ {*}$remaining_args + tailcall $command $_ID_ {*}$remaining_args + } + } + } + #------------ + + + if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { + return $_ID_ + } + + + #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" + + + + #puts stderr "this_info_dict: $this_info_dict" + + + + + if {![llength $args]} { + #should return some sort of public info.. i.e probably not the ID which is an implementation detail + #return cmd + return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID + + #return a dict keyed on object command name - (suitable as use for a .. Create 'target') + #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped + #return [list $object_command [list -id $this_OID ]] + } elseif {[llength $args] == 1} { + #short-circuit the single index case for speed. + if {[lindex $args 0] ni {.. . -- - & @ # , !}} { + #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method + lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method + + tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] + } elseif {[lindex $args 0] eq {--}} { + + #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. + # - combined with using UUIDs for $OID, and a secured/removed metaface on the object + # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) + # - this could effectively hide the object's namespaces,vars etc from the caller (?) + return [set ::p::${this_OID}::_meta::map] + } + } + + + + #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) + #incr c + #set reduce ::p::reducer${this_OID}_$c + set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] + #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" + coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args + + + set current_ID_ $_ID_ + + set final 0 + set result "" + while {$final == 0} { + #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) + set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] + #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" + #if {[string match *Destroy $command]} { + # puts stdout " calling Destroy reduction_args:'$reduction_args'" + #} + if {$final == 1} { + + if {[llength $command] == 1} { + if {$command eq "_exec_"} { + tailcall {*}$reduction_args + } + if {[llength [info commands $command]]} { + tailcall {*}$command $current_ID_ {*}$reduction_args + } + set cmdname [namespace tail $command] + set this_OID [lindex [dict get $current_ID_ i this] 0 0] + if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { + lset command 0 ::p::${this_OID}::(UNKNOWN) + tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" + } + + } else { + #e.g lindex {a b c} + tailcall {*}$command {*}$reduction_args + } + + + } else { + if {[lindex $command 0] eq "_exec_"} { + set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] + + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] + } else { + if {[llength $command] == 1} { + if {![llength [info commands $command]]} { + set cmdname [namespace tail $command] + set this_OID [lindex [dict get $current_ID_ i this] 0 0] + if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { + + lset command 0 ::p::${this_OID}::(UNKNOWN) + set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" + } + } else { + #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] + set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] + + } + } else { + set result [uplevel 1 [list {*}$command {*}$reduction_args]] + } + + if {[llength [info commands $result]]} { + if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { + #looks like a pattern command + set current_ID_ [$result .. INVOCANTDATA] + + + #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA + #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { + # set current_ID_ $result_invocantdata + #} else { + # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" + #} + } else { + #non-pattern command + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + } + } else { + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) + + } + } + + } + } + error "Assert: Shouldn't get here (end of ::p::predator2)" + #return $result +} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 50ea5082..61a454fa 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -2469,7 +2469,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 { @@ -5116,6 +5116,7 @@ tcl::namespace::eval punk::ansi::ta { # arrow keys -> ESC O A, ESC O B, ESC O C, ESC O D # plus more for auxiliary keypad codes in keypad application mode (and some in numeric mode) + #regexp expanded syntax = ?x variable re_ansi_detect {(?x) (?:\x1b(?:\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|c|7|8|M|D|E|H|=|>|<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.))|\((?:0|B)|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|(?:\#(?:3|4|5|6|8)))) |(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c) diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm index 60764f07..aaa595ae 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -108,8 +108,10 @@ namespace eval punk::cap::handlers::templates { #todo - handle wrapped or unwrapped tarjar files - in which case we have to adjust tmfolder appropriately #set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder - set projectinfo [punk::repo::find_repos $tmfolder] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $tmfolder] ;#slow - REVIEW + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $tmfolder] + #store the projectbase even if it's empty string set extended_capdict $capdict set resolved_path [file join $tmfolder $path] @@ -148,8 +150,9 @@ namespace eval punk::cap::handlers::templates { return 0 } set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review - set projectinfo [punk::repo::find_repos $shellbase] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $shellbase] + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $shellbase] set extended_capdict $capdict dict set extended_capdict vendor $vendor @@ -166,8 +169,9 @@ namespace eval punk::cap::handlers::templates { return 0 } set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review - set projectinfo [punk::repo::find_repos $shellbase] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $shellbase] + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $shellbase] set extended_capdict $capdict dict set extended_capdict vendor $vendor @@ -183,8 +187,9 @@ namespace eval punk::cap::handlers::templates { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' which doesn't seem to exist" return 0 } - set projectinfo [punk::repo::find_repos $normpath] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $normpath] + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $normpath] #todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder set extended_capdict $capdict @@ -244,6 +249,18 @@ namespace eval punk::cap::handlers::templates { # -- --- --- --- --- --- --- namespace export * namespace eval class { + variable PUNKARGS + #set argd [punk::args::get_dict { + # @id -id "::punk::cap::handlers::templates::class::api folders" + # -startdir -default "" + # @values -max 0 + #} $args] + lappend PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api folders" + -startdir -default "" + @values -max 0 + }] + oo::class create api { #return a dict keyed on folder with source pkg as value constructor {capname} { @@ -253,11 +270,8 @@ namespace eval punk::cap::handlers::templates { set capabilityname $capname } method folders {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api folders" - -startdir -default "" - @values -max 0 - } $args] + #puts "--folders $args" + set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] set opts [dict get $argd opts] set opt_startdir [dict get $opts -startdir] @@ -270,6 +284,10 @@ namespace eval punk::cap::handlers::templates { set startdir $opt_startdir } } + set searchbase $startdir + #set pathinfo [punk::repo::find_repos $searchbase] ;#relatively slow! REVIEW - pass as arg? cache? + #set pwd_projectroot [dict get $pathinfo closest] + set pwd_projectroot [punk::repo::find_project $searchbase] variable capabilityname @@ -314,9 +332,9 @@ namespace eval punk::cap::handlers::templates { set module_projectroot [dict get $capdecl_extended projectbase] dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot] } elseif {$pathtype eq "currentproject_multivendor"} { - set searchbase $startdir - set pathinfo [punk::repo::find_repos $searchbase] - set pwd_projectroot [dict get $pathinfo closest] + #set searchbase $startdir + #set pathinfo [punk::repo::find_repos $searchbase] + #set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { set deckbase [file join $pwd_projectroot $path] if {![file exists $deckbase]} { @@ -349,9 +367,9 @@ namespace eval punk::cap::handlers::templates { } } } elseif {$pathtype eq "currentproject"} { - set searchbase $startdir - set pathinfo [punk::repo::find_repos $searchbase] - set pwd_projectroot [dict get $pathinfo closest] + #set searchbase $startdir + #set pathinfo [punk::repo::find_repos $searchbase] + #set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { #path relative to projectroot already validated by handler as being within a currentproject_multivendor tree set targetfolder [file join $pwd_projectroot $path] @@ -489,8 +507,9 @@ namespace eval punk::cap::handlers::templates { set refdict [my get_itemdict_projectlayoutrefs {*}$args] set layoutdict [dict create] - set projectinfo [punk::repo::find_repos $searchbase] - set projectroot [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $searchbase] + #set projectroot [dict get $projectinfo closest] + set projectroot [punk::repo::find_project $searchbase] dict for {layoutname refinfo} $refdict { set templatepathtype [dict get $refinfo sourceinfo pathtype] @@ -760,6 +779,10 @@ namespace eval punk::cap::handlers::templates { } +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::cap::handlers::templates ::punk::cap::handlers::templates::class +} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm index ac70e97b..5532cb80 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -1,487 +1,487 @@ - -tcl::namespace::eval punk::config { - variable loaded - variable startup ;#include env overrides - variable running - variable punk_env_vars - variable other_env_vars - - variable vars - - namespace export {[a-z]*} - - #todo - XDG_DATA_HOME etc - #https://specifications.freedesktop.org/basedir-spec/latest/ - # see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ - - proc init {} { - variable defaults - variable startup - variable running - variable punk_env_vars - variable punk_env_vars_config - variable other_env_vars - variable other_env_vars_config - - set exename "" - catch { - #catch for safe interps - #safe base will return empty string, ordinary safe interp will raise error - set exename [tcl::info::nameofexecutable] - } - if {$exename ne ""} { - set exefolder [file dirname $exename] - #default file logs to logs folder at same level as exe if writable, or empty string - set log_folder [file normalize $exefolder/../logs] ;#~2ms - #tcl::dict::set startup scriptlib $exefolder/scriptlib - #tcl::dict::set startup apps $exefolder/../../punkapps - - #todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc - set default_scriptlib $exefolder/scriptlib - set default_apps $exefolder/../../punkapps - if {[file isdirectory $log_folder] && [file writable $log_folder]} { - #tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt - #tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt - set default_logfile_stdout $log_folder/repl-exec-stdout.txt - set default_logfile_stderr $log_folder/repl-exec-stderr.txt - } else { - set default_logfile_stdout "" - set default_logfile_stderr "" - } - } else { - #probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island - #review - todo? - #tcl::dict::set startup scriptlib "" - #tcl::dict::set startup apps "" - set default_scriptlib "" - set default_apps "" - set default_logfile_stdout "" - set default_logfile_stderr "" - } - - # auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run - - #optional channel transforms on stdout/stderr. - #can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands - #If no distinction necessary - should use default_color_ - #The counterpart: default_color__repl is a transform that is added and removed with each repl evaluation. - #startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default - set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) - set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only - #This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. - #set default_color_stderr "red bold" - #set default_color_stderr "web-lightsalmon" - set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive - set default_color_stderr_repl "" ;#during repl call only - - set homedir "" - if {[catch { - #depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp - #other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp - set homedir [file home] - } errM]} { - #tcl 8.6 doesn't have file home.. try again - if {[info exists ::env(HOME)]} { - set homedir $::env(HOME) - } - } - - - # per user xdg vars - # --- - set default_xdg_config_home "" ;#config data - portable - set default_xdg_data_home "" ;#data the user likely to want to be portable - set default_xdg_cache_home "" ;#local cache - set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home - # --- - set default_xdg_data_dirs "" ;#non-user specific - #xdg_config_dirs ? - #xdg_runtime_dir ? - - - #review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) - #(safe interp generally won't have access to ::env either) - #This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. - if {$homedir ne ""} { - if {"windows" eq $::tcl_platform(platform)} { - #as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. - #we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) - #using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. - if {[info exists ::env(APPDATA)]} { - set default_xdg_config_home $::env(APPDATA) - set default_xdg_data_home $::env(APPDATA) - } - - #The xdg_cache_home should be kept local - if {[info exists ::env(LOCALAPPDATA)]} { - set default_xdg_cache_home $::env(LOCALAPPDATA) - set default_xdg_state_home $::env(LOCALAPPDATA) - } - - if {[info exists ::env(PROGRAMDATA)]} { - #- equiv env(ALLUSERSPROFILE) ? - set default_xdg_data_dirs $::env(PROGRAMDATA) - } - - } else { - #follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html - set default_xdg_config_home [file join $homedir .config] - set default_xdg_data_home [file join $homedir .local share] - set default_xdg_cache_home [file join $homedir .cache] - set default_xdg_state_home [file join $homedir .local state] - set default_xdg_data_dirs /usr/local/share - } - } - - set defaults [dict create\ - apps $default_apps\ - config ""\ - configset ".punkshell"\ - scriptlib $default_scriptlib\ - color_stdout $default_color_stdout\ - color_stdout_repl $default_color_stdout_repl\ - color_stderr $default_color_stderr\ - color_stderr_repl $default_color_stderr_repl\ - logfile_stdout $default_logfile_stdout\ - logfile_stderr $default_logfile_stderr\ - logfile_active 0\ - syslog_stdout "127.0.0.1:514"\ - syslog_stderr "127.0.0.1:514"\ - syslog_active 0\ - auto_exec_mechanism exec\ - auto_noexec 0\ - xdg_config_home $default_xdg_config_home\ - xdg_data_home $default_xdg_data_home\ - xdg_cache_home $default_xdg_cache_home\ - xdg_state_home $default_xdg_state_home\ - xdg_data_dirs $default_xdg_data_dirs\ - theme_posh_override ""\ - posh_theme ""\ - posh_themes_path ""\ - ] - - set startup $defaults - #load values from saved config file - $xdg_config_home/punk/punk.config ? - #typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. - #that's possibly ok for the PUNK_ vars - #however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? - #making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? - #simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden - #- requiring user to manually unset any unwanted env vars when launching? - - #we are likely to want the saved configs for subshells/decks to override them however. - - #todo - load/save config file - - #todo - define which configvars are settable in env - #list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) - set punk_env_vars_config [dict create \ - PUNK_APPS {type pathlist}\ - PUNK_CONFIG {type string}\ - PUNK_CONFIGSET {type string}\ - PUNK_SCRIPTLIB {type string}\ - PUNK_AUTO_EXEC_MECHANISM {type string}\ - PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ - PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ - PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ - PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ - PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ - PUNK_LOGFILE_STDOUT {type string}\ - PUNK_LOGFILE_STDERR {type string}\ - PUNK_LOGFILE_ACTIVE {type string}\ - PUNK_SYSLOG_STDOUT {type string}\ - PUNK_SYSLOG_STDERR {type string}\ - PUNK_SYSLOG_ACTIVE {type string}\ - PUNK_THEME_POSH_OVERRIDE {type string}\ - ] - set punk_env_vars [dict keys $punk_env_vars_config] - - #override with env vars if set - foreach {evar varinfo} $punk_env_vars_config { - if {[info exists ::env($evar)]} { - set vartype [dict get $varinfo type] - set f [set ::env($evar)] - if {$f ne "default"} { - #e.g PUNK_SCRIPTLIB -> scriptlib - set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] - if {$vartype eq "pathlist"} { - #colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system - #Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. - #For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. - #some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. - #An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting - # - but some programs have been known to split this value on colon anyway, which breaks things on windows. - set paths [split $f $::tcl_platform(pathSeparator)] - set final [list] - #eliminate empty values (leading or trailing or extraneous separators) - foreach p $paths { - if {[tcl::string::trim $p] ne ""} { - lappend final $p - } - } - tcl::dict::set startup $varname $final - } else { - tcl::dict::set startup $varname $f - } - } - } - } - - # https://no-color.org - #if {[info exists ::env(NO_COLOR)]} { - # if {$::env(NO_COLOR) ne ""} { - # set colour_disabled 1 - # } - #} - set other_env_vars_config [dict create\ - NO_COLOR {type string}\ - XDG_CONFIG_HOME {type string}\ - XDG_DATA_HOME {type string}\ - XDG_CACHE_HOME {type string}\ - XDG_STATE_HOME {type string}\ - XDG_DATA_DIRS {type pathlist}\ - POSH_THEME {type string}\ - POSH_THEMES_PATH {type string}\ - TCLLIBPATH {type string}\ - ] - lassign [split [info tclversion] .] tclmajorv tclminorv - #don't rely on lseq or punk::lib for now.. - set relevant_minors [list] - for {set i 0} {$i <= $tclminorv} {incr i} { - lappend relevant_minors $i - } - foreach minor $relevant_minors { - set vname TCL${tclmajorv}_${minor}_TM_PATH - if {$minor eq $tclminorv || [info exists ::env($vname)]} { - dict set other_env_vars_config $vname {type string} - } - } - set other_env_vars [dict keys $other_env_vars_config] - - foreach {evar varinfo} $other_env_vars_config { - if {[info exists ::env($evar)]} { - set vartype [dict get $varinfo type] - set f [set ::env($evar)] - if {$f ne "default"} { - set varname [tcl::string::tolower $evar] - if {$vartype eq "pathlist"} { - set paths [split $f $::tcl_platform(pathSeparator)] - set final [list] - #eliminate empty values (leading or trailing or extraneous separators) - foreach p $paths { - if {[tcl::string::trim $p] ne ""} { - lappend final $p - } - } - tcl::dict::set startup $varname $final - } else { - tcl::dict::set startup $varname $f - } - } - } - } - - - #unset -nocomplain vars - - #todo - set running [tcl::dict::create] - set running [tcl::dict::merge $running $startup] - } - init - - #todo - proc Apply {config} { - puts stderr "punk::config::Apply partially implemented" - set configname [string map {-config ""} $config] - if {$configname in {startup running}} { - upvar ::punk::config::$configname applyconfig - - if {[dict exists $applyconfig auto_noexec]} { - set auto [dict get $applyconfig auto_noexec] - if {![string is boolean -strict $auto]} { - error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" - } - if {$auto} { - set ::auto_noexec 1 - } else { - #puts "auto_noexec false" - unset -nocomplain ::auto_noexec - } - } - - } else { - error "no config named '$config' found" - } - return "apply done" - } - Apply startup - - #todo - consider how to divide up settings, categories, 'devices', decks etc - proc get_running_global {varname} { - variable running - if {[dict exists $running $varname]} { - return [dict get $running $varname] - } - error "No such global configuration item '$varname' found in running config" - } - proc get_startup_global {varname} { - variable startup - if {[dict exists $startup $varname]} { - return [dict get $startup $varname] - } - error "No such global configuration item '$varname' found in startup config" - } - - proc get {whichconfig {globfor *}} { - variable startup - variable running - switch -- $whichconfig { - config - startup - startup-config - startup-configuration { - #show *startup* config - different behaviour may be confusing to those used to router startup and running configs - set configdata $startup - } - running - running-config - running-configuration { - set configdata $running - } - default { - error "Unknown config name '$whichconfig' - try startup or running" - } - } - if {$globfor eq "*"} { - return $configdata - } else { - set keys [dict keys $configdata [string tolower $globfor]] - set filtered [dict create] - foreach k $keys { - dict set filtered $k [dict get $configdata $k] - } - return $filtered - } - } - - proc configure {args} { - set argdef { - @id -id ::punk::config::configure - @cmd -name punk::config::configure -help\ - "UNIMPLEMENTED" - @values -min 1 -max 1 - whichconfig -type string -choices {startup running stop} - } - set argd [punk::args::get_dict $argdef $args] - return "unimplemented - $argd" - } - - proc show {whichconfig {globfor *}} { - #todo - tables for console - set configdata [punk::config::get $whichconfig $globfor] - return [punk::lib::showdict $configdata] - } - - - - #e.g - # copy running-config startup-config - # copy startup-config test-config.cfg - # copy backup-config.cfg running-config - #review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite - #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration - proc copy {args} { - set argdef { - @id -id ::punk::config::copy - @cmd -name punk::config::copy -help\ - "Copy a partial or full configuration from one config to another - If a target config has additional settings, then the source config can be considered to be partial with regards to the target. - " - -type -default "" -choices {replace merge} -help\ - "Defaults to merge when target is running-config - Defaults to replace when source is running-config" - @values -min 2 -max 2 - fromconfig -help\ - "running or startup or file name (not fully implemented)" - toconfig -help\ - "running or startup or file name (not fully implemented)" - } - set argd [punk::args::get_dict $argdef $args] - set fromconfig [dict get $argd values fromconfig] - set toconfig [dict get $argd values toconfig] - set fromconfig [string map {-config ""} $fromconfig] - set toconfig [string map {-config ""} $toconfig] - - set copytype [dict get $argd opts -type] - - - #todo - warn & prompt if doing merge copy to startup - switch -exact -- $fromconfig-$toconfig { - running-startup { - if {$copytype eq ""} { - set copytype replace ;#full configuration - } - if {$copytype eq "replace"} { - error "punk::config::copy error. full configuration copy from running to startup config not yet supported" - } else { - error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" - } - } - startup-running { - #default type merge - even though it's not always what is desired - if {$copytype eq ""} { - set copytype merge ;#load in a partial configuration - } - - #warn/prompt either way - if {$copytype eq "replace"} { - #some routers require use of a separate command for this branch. - #presumably to ensure the user doesn't accidentally load partials onto a running system - # - error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" - } else { - error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" - } - } - default { - error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" - } - } - } - - - - - -} - - - - - -#todo - move to cli? -::tcl::namespace::eval punk::config { - #todo - something better - 'previous' rather than reverting to startup - proc channelcolors {{onoff {}}} { - variable running - variable startup - - if {![string length $onoff]} { - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] - } else { - if {![string is boolean $onoff]} { - error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" - } - if {$onoff} { - dict set running color_stdout [dict get $startup color_stdout] - dict set running color_stderr [dict get $startup color_stderr] - } else { - dict set running color_stdout "" - dict set running color_stderr "" - } - } - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] - } -} - -package provide punk::config [tcl::namespace::eval punk::config { - variable version - set version 0.1 - + +tcl::namespace::eval punk::config { + variable loaded + variable startup ;#include env overrides + variable running + variable punk_env_vars + variable other_env_vars + + variable vars + + namespace export {[a-z]*} + + #todo - XDG_DATA_HOME etc + #https://specifications.freedesktop.org/basedir-spec/latest/ + # see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ + + proc init {} { + variable defaults + variable startup + variable running + variable punk_env_vars + variable punk_env_vars_config + variable other_env_vars + variable other_env_vars_config + + set exename "" + catch { + #catch for safe interps + #safe base will return empty string, ordinary safe interp will raise error + set exename [tcl::info::nameofexecutable] + } + if {$exename ne ""} { + set exefolder [file dirname $exename] + #default file logs to logs folder at same level as exe if writable, or empty string + set log_folder [file normalize $exefolder/../logs] ;#~2ms + #tcl::dict::set startup scriptlib $exefolder/scriptlib + #tcl::dict::set startup apps $exefolder/../../punkapps + + #todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc + set default_scriptlib $exefolder/scriptlib + set default_apps $exefolder/../../punkapps + if {[file isdirectory $log_folder] && [file writable $log_folder]} { + #tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt + #tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt + set default_logfile_stdout $log_folder/repl-exec-stdout.txt + set default_logfile_stderr $log_folder/repl-exec-stderr.txt + } else { + set default_logfile_stdout "" + set default_logfile_stderr "" + } + } else { + #probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island + #review - todo? + #tcl::dict::set startup scriptlib "" + #tcl::dict::set startup apps "" + set default_scriptlib "" + set default_apps "" + set default_logfile_stdout "" + set default_logfile_stderr "" + } + + # auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run + + #optional channel transforms on stdout/stderr. + #can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands + #If no distinction necessary - should use default_color_ + #The counterpart: default_color__repl is a transform that is added and removed with each repl evaluation. + #startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default + set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) + set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only + #This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. + #set default_color_stderr "red bold" + #set default_color_stderr "web-lightsalmon" + set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive + set default_color_stderr_repl "" ;#during repl call only + + set homedir "" + if {[catch { + #depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp + #other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp + set homedir [file home] + } errM]} { + #tcl 8.6 doesn't have file home.. try again + if {[info exists ::env(HOME)]} { + set homedir $::env(HOME) + } + } + + + # per user xdg vars + # --- + set default_xdg_config_home "" ;#config data - portable + set default_xdg_data_home "" ;#data the user likely to want to be portable + set default_xdg_cache_home "" ;#local cache + set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home + # --- + set default_xdg_data_dirs "" ;#non-user specific + #xdg_config_dirs ? + #xdg_runtime_dir ? + + + #review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) + #(safe interp generally won't have access to ::env either) + #This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. + if {$homedir ne ""} { + if {"windows" eq $::tcl_platform(platform)} { + #as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. + #we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) + #using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. + if {[info exists ::env(APPDATA)]} { + set default_xdg_config_home $::env(APPDATA) + set default_xdg_data_home $::env(APPDATA) + } + + #The xdg_cache_home should be kept local + if {[info exists ::env(LOCALAPPDATA)]} { + set default_xdg_cache_home $::env(LOCALAPPDATA) + set default_xdg_state_home $::env(LOCALAPPDATA) + } + + if {[info exists ::env(PROGRAMDATA)]} { + #- equiv env(ALLUSERSPROFILE) ? + set default_xdg_data_dirs $::env(PROGRAMDATA) + } + + } else { + #follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html + set default_xdg_config_home [file join $homedir .config] + set default_xdg_data_home [file join $homedir .local share] + set default_xdg_cache_home [file join $homedir .cache] + set default_xdg_state_home [file join $homedir .local state] + set default_xdg_data_dirs /usr/local/share + } + } + + set defaults [dict create\ + apps $default_apps\ + config ""\ + configset ".punkshell"\ + scriptlib $default_scriptlib\ + color_stdout $default_color_stdout\ + color_stdout_repl $default_color_stdout_repl\ + color_stderr $default_color_stderr\ + color_stderr_repl $default_color_stderr_repl\ + logfile_stdout $default_logfile_stdout\ + logfile_stderr $default_logfile_stderr\ + logfile_active 0\ + syslog_stdout "127.0.0.1:514"\ + syslog_stderr "127.0.0.1:514"\ + syslog_active 0\ + auto_exec_mechanism exec\ + auto_noexec 0\ + xdg_config_home $default_xdg_config_home\ + xdg_data_home $default_xdg_data_home\ + xdg_cache_home $default_xdg_cache_home\ + xdg_state_home $default_xdg_state_home\ + xdg_data_dirs $default_xdg_data_dirs\ + theme_posh_override ""\ + posh_theme ""\ + posh_themes_path ""\ + ] + + set startup $defaults + #load values from saved config file - $xdg_config_home/punk/punk.config ? + #typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. + #that's possibly ok for the PUNK_ vars + #however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? + #making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? + #simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden + #- requiring user to manually unset any unwanted env vars when launching? + + #we are likely to want the saved configs for subshells/decks to override them however. + + #todo - load/save config file + + #todo - define which configvars are settable in env + #list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) + set punk_env_vars_config [dict create \ + PUNK_APPS {type pathlist}\ + PUNK_CONFIG {type string}\ + PUNK_CONFIGSET {type string}\ + PUNK_SCRIPTLIB {type string}\ + PUNK_AUTO_EXEC_MECHANISM {type string}\ + PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ + PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ + PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ + PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ + PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ + PUNK_LOGFILE_STDOUT {type string}\ + PUNK_LOGFILE_STDERR {type string}\ + PUNK_LOGFILE_ACTIVE {type string}\ + PUNK_SYSLOG_STDOUT {type string}\ + PUNK_SYSLOG_STDERR {type string}\ + PUNK_SYSLOG_ACTIVE {type string}\ + PUNK_THEME_POSH_OVERRIDE {type string}\ + ] + set punk_env_vars [dict keys $punk_env_vars_config] + + #override with env vars if set + foreach {evar varinfo} $punk_env_vars_config { + if {[info exists ::env($evar)]} { + set vartype [dict get $varinfo type] + set f [set ::env($evar)] + if {$f ne "default"} { + #e.g PUNK_SCRIPTLIB -> scriptlib + set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] + if {$vartype eq "pathlist"} { + #colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system + #Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. + #For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. + #some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. + #An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting + # - but some programs have been known to split this value on colon anyway, which breaks things on windows. + set paths [split $f $::tcl_platform(pathSeparator)] + set final [list] + #eliminate empty values (leading or trailing or extraneous separators) + foreach p $paths { + if {[tcl::string::trim $p] ne ""} { + lappend final $p + } + } + tcl::dict::set startup $varname $final + } else { + tcl::dict::set startup $varname $f + } + } + } + } + + # https://no-color.org + #if {[info exists ::env(NO_COLOR)]} { + # if {$::env(NO_COLOR) ne ""} { + # set colour_disabled 1 + # } + #} + set other_env_vars_config [dict create\ + NO_COLOR {type string}\ + XDG_CONFIG_HOME {type string}\ + XDG_DATA_HOME {type string}\ + XDG_CACHE_HOME {type string}\ + XDG_STATE_HOME {type string}\ + XDG_DATA_DIRS {type pathlist}\ + POSH_THEME {type string}\ + POSH_THEMES_PATH {type string}\ + TCLLIBPATH {type string}\ + ] + lassign [split [info tclversion] .] tclmajorv tclminorv + #don't rely on lseq or punk::lib for now.. + set relevant_minors [list] + for {set i 0} {$i <= $tclminorv} {incr i} { + lappend relevant_minors $i + } + foreach minor $relevant_minors { + set vname TCL${tclmajorv}_${minor}_TM_PATH + if {$minor eq $tclminorv || [info exists ::env($vname)]} { + dict set other_env_vars_config $vname {type string} + } + } + set other_env_vars [dict keys $other_env_vars_config] + + foreach {evar varinfo} $other_env_vars_config { + if {[info exists ::env($evar)]} { + set vartype [dict get $varinfo type] + set f [set ::env($evar)] + if {$f ne "default"} { + set varname [tcl::string::tolower $evar] + if {$vartype eq "pathlist"} { + set paths [split $f $::tcl_platform(pathSeparator)] + set final [list] + #eliminate empty values (leading or trailing or extraneous separators) + foreach p $paths { + if {[tcl::string::trim $p] ne ""} { + lappend final $p + } + } + tcl::dict::set startup $varname $final + } else { + tcl::dict::set startup $varname $f + } + } + } + } + + + #unset -nocomplain vars + + #todo + set running [tcl::dict::create] + set running [tcl::dict::merge $running $startup] + } + init + + #todo + proc Apply {config} { + puts stderr "punk::config::Apply partially implemented" + set configname [string map {-config ""} $config] + if {$configname in {startup running}} { + upvar ::punk::config::$configname applyconfig + + if {[dict exists $applyconfig auto_noexec]} { + set auto [dict get $applyconfig auto_noexec] + if {![string is boolean -strict $auto]} { + error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" + } + if {$auto} { + set ::auto_noexec 1 + } else { + #puts "auto_noexec false" + unset -nocomplain ::auto_noexec + } + } + + } else { + error "no config named '$config' found" + } + return "apply done" + } + Apply startup + + #todo - consider how to divide up settings, categories, 'devices', decks etc + proc get_running_global {varname} { + variable running + if {[dict exists $running $varname]} { + return [dict get $running $varname] + } + error "No such global configuration item '$varname' found in running config" + } + proc get_startup_global {varname} { + variable startup + if {[dict exists $startup $varname]} { + return [dict get $startup $varname] + } + error "No such global configuration item '$varname' found in startup config" + } + + proc get {whichconfig {globfor *}} { + variable startup + variable running + switch -- $whichconfig { + config - startup - startup-config - startup-configuration { + #show *startup* config - different behaviour may be confusing to those used to router startup and running configs + set configdata $startup + } + running - running-config - running-configuration { + set configdata $running + } + default { + error "Unknown config name '$whichconfig' - try startup or running" + } + } + if {$globfor eq "*"} { + return $configdata + } else { + set keys [dict keys $configdata [string tolower $globfor]] + set filtered [dict create] + foreach k $keys { + dict set filtered $k [dict get $configdata $k] + } + return $filtered + } + } + + proc configure {args} { + set argdef { + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ + "UNIMPLEMENTED" + @values -min 1 -max 1 + whichconfig -type string -choices {startup running stop} + } + set argd [punk::args::get_dict $argdef $args] + return "unimplemented - $argd" + } + + proc show {whichconfig {globfor *}} { + #todo - tables for console + set configdata [punk::config::get $whichconfig $globfor] + return [punk::lib::showdict $configdata] + } + + + + #e.g + # copy running-config startup-config + # copy startup-config test-config.cfg + # copy backup-config.cfg running-config + #review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite + #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration + proc copy {args} { + set argdef { + @id -id ::punk::config::copy + @cmd -name punk::config::copy -help\ + "Copy a partial or full configuration from one config to another + If a target config has additional settings, then the source config can be considered to be partial with regards to the target. + " + -type -default "" -choices {replace merge} -help\ + "Defaults to merge when target is running-config + Defaults to replace when source is running-config" + @values -min 2 -max 2 + fromconfig -help\ + "running or startup or file name (not fully implemented)" + toconfig -help\ + "running or startup or file name (not fully implemented)" + } + set argd [punk::args::get_dict $argdef $args] + set fromconfig [dict get $argd values fromconfig] + set toconfig [dict get $argd values toconfig] + set fromconfig [string map {-config ""} $fromconfig] + set toconfig [string map {-config ""} $toconfig] + + set copytype [dict get $argd opts -type] + + + #todo - warn & prompt if doing merge copy to startup + switch -exact -- $fromconfig-$toconfig { + running-startup { + if {$copytype eq ""} { + set copytype replace ;#full configuration + } + if {$copytype eq "replace"} { + error "punk::config::copy error. full configuration copy from running to startup config not yet supported" + } else { + error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" + } + } + startup-running { + #default type merge - even though it's not always what is desired + if {$copytype eq ""} { + set copytype merge ;#load in a partial configuration + } + + #warn/prompt either way + if {$copytype eq "replace"} { + #some routers require use of a separate command for this branch. + #presumably to ensure the user doesn't accidentally load partials onto a running system + # + error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" + } else { + error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" + } + } + default { + error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" + } + } + } + + + + + +} + + + + + +#todo - move to cli? +::tcl::namespace::eval punk::config { + #todo - something better - 'previous' rather than reverting to startup + proc channelcolors {{onoff {}}} { + variable running + variable startup + + if {![string length $onoff]} { + return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + } else { + if {![string is boolean $onoff]} { + error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" + } + if {$onoff} { + dict set running color_stdout [dict get $startup color_stdout] + dict set running color_stderr [dict get $startup color_stderr] + } else { + dict set running color_stdout "" + dict set running color_stderr "" + } + } + return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + } +} + +package provide punk::config [tcl::namespace::eval punk::config { + variable version + set version 0.1 + }] \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm index 69f2f5cb..a4bc3c70 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -767,6 +767,8 @@ namespace eval punk::mix::base { dict for {path pathinfo} $dict_path_cksum { + puts "fill_relativecksums_from_base_and_relativepathdict-->$path REVIEW" + #review to see if we process same path repeatedly, so could avoid repeated 'file exists $fullpath' below by caching a glob if {![dict exists $pathinfo cksum]} { dict set pathinfo cksum "" } else { @@ -851,7 +853,7 @@ namespace eval punk::mix::base { } } else { - if {[file type $specifiedpath] eq "relative"} { + if {[file pathtype $specifiedpath] eq "relative"} { #if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage set targetpath [file normalize $specifiedpath] set storedpath $targetpath @@ -911,6 +913,7 @@ namespace eval punk::mix::base { } #buildruntime.exe obsolete.. + puts stderr "warning obsolete? get_all_vfs_build_cksums 'buildruntime.exe'???" set fullpath_buildruntime $buildfolder/buildruntime.exe set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 3cf64b33..a099c9b0 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -412,9 +412,9 @@ namespace eval punk::mix::cli { set repopaths [punk::repo::find_repos [pwd]] set repos [dict get $repopaths repos] if {![llength $repos]} { - append result [dict get $repopaths warnings] + append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] } else { - append result [dict get $repopaths warnings] + append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] lassign [lindex $repos 0] repopath repotypes if {"fossil" in $repotypes} { #review - multiple process launches to fossil a bit slow on windows.. @@ -739,7 +739,7 @@ namespace eval punk::mix::cli { } } else { - puts -nonewline stderr "." + puts -nonewline stderr "P" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $build_event targetset_end SKIPPED @@ -771,7 +771,7 @@ namespace eval punk::mix::cli { $event targetset_end OK -note "zip modpod" } } else { - puts -nonewline stderr "." + puts -nonewline stderr "p" set did_skip 1 if {$is_interesting} { puts stderr "$modulefile [$event targetset_source_changes]" @@ -893,7 +893,7 @@ namespace eval punk::mix::cli { if {$is_interesting} { puts stdout "skipping module $current_source_dir/$m - no change in sources detected" } - puts -nonewline stderr "." + puts -nonewline stderr "m" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $event targetset_end SKIPPED @@ -935,7 +935,7 @@ namespace eval punk::mix::cli { #set file_record [punkcheck::installfile_finished_install $basedir $file_record] $event targetset_end OK -note "already versioned module" } else { - puts -nonewline stderr "." + puts -nonewline stderr "f" set did_skip 1 if {$is_interesting} { puts stderr "$current_source_dir/$m [$event targetset_source_changes]" @@ -951,7 +951,8 @@ namespace eval punk::mix::cli { if {$CALLDEPTH >= $max_depth} { set subdirs [list] } else { - set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set targets_existing [glob -nocomplain -dir $target_module_dir -type d -tail {*}$subdirs] } #puts stderr "subdirs: $subdirs" foreach d $subdirs { @@ -965,7 +966,10 @@ namespace eval punk::mix::cli { if {$skipdir} { continue } - if {![file exists $target_module_dir/$d]} { + #if {![file exists $target_module_dir/$d]} { + # file mkdir $target_module_dir/$d + #} + if {$d ni $targets_existing} { file mkdir $target_module_dir/$d } lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm index 883e02d2..409796fc 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm @@ -49,7 +49,7 @@ namespace eval punk::mix::commandset::buildsuite { set path_parts [file split [lindex $du_record 1]] ;#should handle spaced-paths ok. set s [lindex $path_parts end-1] set p [lindex $path_parts end] - + #This handles case where a project folder is same name as suite e.g src/buildsuites/tcl/tcl #so we can't just use tail as dict key. We could assume last record is always total - but if {![string match -nocase $s $suite]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm index c6c83b69..a3784c00 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm @@ -26,7 +26,7 @@ namespace eval punk::mix::commandset::debug { namespace export get paths namespace path ::punk::mix::cli - #Except for 'get' - all debug commands should emit to stdout + #Except for 'get' - all debug commands should emit to stdout proc paths {} { set out "" puts stdout "find_repos output:" @@ -40,7 +40,7 @@ namespace eval punk::mix::commandset::debug { set template_base_dict [punk::mix::base::lib::get_template_basefolders] puts stdout "get_template_basefolders output:" pdict template_base_dict */* - return + return } #call other debug command - but capture stdout as return value @@ -84,9 +84,9 @@ namespace eval punk::mix::commandset::debug { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index ae21d348..2bc0f01c 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -26,8 +26,10 @@ namespace eval punk::mix::commandset::module { namespace export * proc paths {} { - set roots [punk::repo::find_repos ""] - set project [lindex [dict get $roots project] 0] + #set roots [punk::repo::find_repos ""] + #set project [lindex [dict get $roots project] 0] + set project [punk::repo::find_project ""] + if {$project ne ""} { set is_project 1 set searchbase $project 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 2ff8ac06..f670c8c0 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 @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.0] #[copyright "2023"] #[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] -#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] +#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] #[require punk::mix::commandset::project] #[description] @@ -29,25 +29,25 @@ #*** !doctools #[section Overview] #[para] overview of punk::mix::commandset::project -#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g +#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g #[example { # namespace eval myproject::cli { # namespace export * # namespace ensemble create # package require punk::overlay -# +# # package require punk::mix::commandset::project # punk::overlay::import_commandset project . ::punk::mix::commandset::project -# punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection +# punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection # } #}] #[para] Where the . in the above example is the prefix/command separator #[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. -#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new +#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new #[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as projects. #[para] #[subsection Concepts] -#[para] see punk::overlay +#[para] see punk::overlay # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -56,7 +56,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::mix::commandset::project +#[para] packages used by punk::mix::commandset::project #[list_begin itemized] package require Tcl 8.6- @@ -88,7 +88,7 @@ namespace eval punk::mix::commandset::project { namespace export * #*** !doctools #[subsection {Namespace punk::mix::commandset::project}] - #[para] core commandset functions for punk::mix::commandset::project + #[para] core commandset functions for punk::mix::commandset::project #[list_begin definitions] proc _default {} { @@ -133,7 +133,7 @@ namespace eval punk::mix::commandset::project { proc new {newprojectpath_or_name args} { #*** !doctools # [call [fun new] [arg newprojectpath_or_name] [opt args]] - #new project structure - may be dedicated to one module, or contain many. + #new project structure - may be dedicated to one module, or contain many. #create minimal folder structure only by specifying in args: -modules {} if {[file pathtype $newprojectpath_or_name] eq "absolute"} { set projectfullpath [file normalize $newprojectpath_or_name] @@ -185,7 +185,7 @@ namespace eval punk::mix::commandset::project { if {$opt_force || $opt_update} { #generally undesirable to add default project module during an update. #user can use dev module.new manually or supply module name in -modules - set opt_modules [list] + set opt_modules [list] } else { set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl } @@ -207,12 +207,12 @@ namespace eval punk::mix::commandset::project { } #we don't assume 'unknown' is configured to run shell commands if {[string length [package provide shellrun]]} { - set exitinfo [run {*}$scoop_prog install fossil] + set exitinfo [run {*}$scoop_prog install fossil] #scoop tends to return successful exitcode (0) even when packages not found etc. - so exitinfo not much use. puts stdout "scoop install fossil ran with result: $exitinfo" } else { puts stdout "Please wait while scoop runs - there may be a slight delay and then scoop output will be shown. (use punk shellrun package for )" - set result [exec {*}$scoop_prog install fossil] + set result [exec {*}$scoop_prog install fossil] puts stdout $result } catch {::auto_reset} ;#can be missing (unsure under what circumstances - but I've seen it raise error 'invalid command name "auto_reset"') @@ -304,7 +304,7 @@ namespace eval punk::mix::commandset::project { } } - + set project_dir_exists [file exists $projectdir] if {$project_dir_exists && !($opt_force || $opt_update)} { puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" @@ -332,7 +332,7 @@ namespace eval punk::mix::commandset::project { puts stderr $warnmsg } - set fossil_repo_file "" + set fossil_repo_file "" set is_fossil_root 0 if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} { set is_fossil_root 1 @@ -356,7 +356,7 @@ namespace eval punk::mix::commandset::project { return } #review - set fossil_repo_file $repodb_folder/$projectname.fossil + set fossil_repo_file $repodb_folder/$projectname.fossil } if {$fossil_repo_file eq ""} { @@ -378,7 +378,7 @@ namespace eval punk::mix::commandset::project { file mkdir $projectdir - puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" + puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" set resultdict [dict create] set antipaths [list\ src/doc/*\ @@ -394,10 +394,10 @@ namespace eval punk::mix::commandset::project { #default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized if {$opt_force} { - puts stdout "copying layout files - with force applied - overwrite all-targets" + puts stdout "copying layout files - with force applied - overwrite all-targets" set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] } else { - puts stdout "copying layout files - (if source file changed)" + puts stdout "copying layout files - (if source file changed)" set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] } puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -410,10 +410,10 @@ namespace eval punk::mix::commandset::project { puts stdout "no src/doc in source template - update not required" } - #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. + #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. #In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. ## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] - set override_antiglob_dir_core [list #* _aside .git] + set override_antiglob_dir_core [list #* _aside .git] if {[file exists $layout_path/.fossil-custom]} { puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] @@ -430,9 +430,9 @@ namespace eval punk::mix::commandset::project { puts stdout "no .fossil-settings in source template - update not required" } - #scan all files in template + #scan all files in template # - #TODO - deck command to substitute templates? + #TODO - deck command to substitute templates? set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] set stripprefix [file normalize $layout_path] @@ -440,7 +440,7 @@ namespace eval punk::mix::commandset::project { if {[llength $templatefiles]} { puts stdout "Filling template file placeholders with the following tag map:" foreach {placeholder value} $tagmap { - puts stdout " $placeholder -> $value" + puts stdout " $placeholder -> $value" } } foreach templatefullpath $templatefiles { @@ -452,7 +452,7 @@ namespace eval punk::mix::commandset::project { set data2 [string map $tagmap $data] if {$data2 ne $data} { puts stdout "updated template file: $fpath" - set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout + set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout } } else { puts stderr "warning: Missing template file $fpath" @@ -464,7 +464,7 @@ namespace eval punk::mix::commandset::project { if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { - #check if mod-ver.tm file or #modpod-mod-ver folder exist + #check if mod-ver.tm file or #modpod-mod-ver folder exist set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm @@ -482,7 +482,7 @@ namespace eval punk::mix::commandset::project { set overwrite_type zip } else { set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] - set overwrite_type $opt_type + set overwrite_type $opt_type } if {[string tolower $answer] eq "y"} { #REVIEW - all pods zip - for now @@ -503,7 +503,7 @@ namespace eval punk::mix::commandset::project { $installer set_source_target $projectdir/src/doc $projectdir/src/embedded set event [$installer start_event {-install_step kettledoc}] $event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source + $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source #---------- if {\ [llength [dict get [$event targetset_source_changes] changed]]\ @@ -535,7 +535,7 @@ namespace eval punk::mix::commandset::project { if {![punk::repo::is_fossil_root $projectdir]} { set first_fossil 1 - #-k = keep. (only modify the manifest file(s)) + #-k = keep. (only modify the manifest file(s)) if {$is_nested_fossil} { set fossilopen [runx -n {*}$fossil_prog open --nested $repodb_folder/$projectname.fossil -k --workdir $projectdir] } else { @@ -600,11 +600,11 @@ namespace eval punk::mix::commandset::project { #[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied #[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s #[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. - #[para]e.g - #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + #[para]e.g + #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection #[para]Will result in the command being available as projects package require overtype - set db_projects [lib::get_projects $glob] + set db_projects [lib::get_projects $glob] set col1items [lsearch -all -inline -index 0 -subindices $db_projects *] set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] @@ -620,15 +620,15 @@ namespace eval punk::mix::commandset::project { set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] set col3 [string repeat " " $widest3] set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] - - + + append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n append msg [string repeat "=" $tablewidth] \n foreach p $col1items n $col2items c $col3items { append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]" \n - } + } return $msg - #return [list_as_lines [lib::get_projects $glob]] + #return [list_as_lines [lib::get_projects $glob]] } proc detail {{glob {}} args} { package require overtype @@ -640,14 +640,14 @@ namespace eval punk::mix::commandset::project { # -- --- --- --- --- --- --- set opt_description [dict get $opts -description] # -- --- --- --- --- --- --- - - set db_projects [lib::get_projects $glob] + + set db_projects [lib::get_projects $glob] set col1_dbfiles [lsearch -all -inline -index 0 -subindices $db_projects *] set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] set col3items [lmap v $checkouts {llength $v}] - + set col4_pnames [list] set col5_pcodes [list] set col6_dupids [list] @@ -658,13 +658,13 @@ namespace eval punk::mix::commandset::project { set project_name "" set project_code "" set project_desc "" - set db_error "" + set db_error "" if {[file exists $dbfile]} { if {[catch { sqlite3 dbp $dbfile dbp eval {select name,value from config where name like 'project-%';} r { if {$r(name) eq "project-name"} { - set project_name $r(value) + set project_name $r(value) } elseif {$r(name) eq "project-code"} { set project_code $r(value) } elseif {$r(name) eq "project-description"} { @@ -687,7 +687,7 @@ namespace eval punk::mix::commandset::project { } incr file_idx } - + set setid 1 set codeset [dict create] dict for {code dbs} $codes { @@ -696,17 +696,17 @@ namespace eval punk::mix::commandset::project { dict set codeset $code count [llength $dbs] dict set codeset $code seen 0 incr setid - } + } } set dupid 1 foreach pc $col5_pcodes { if {[dict exists $codeset $pc]} { - set seen [dict get $codeset $pc seen] + set seen [dict get $codeset $pc seen] set this_seen [expr {$seen + 1}] dict set codeset $pc seen $this_seen - lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" + lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" } else { - lappend col6_dupids "" + lappend col6_dupids "" } } @@ -732,10 +732,10 @@ namespace eval punk::mix::commandset::project { #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $v}]] set widest7 35 set col7 [string repeat " " $widest7] - - + + set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5 + 1 + $widest6}] - + append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]\ [overtype::left $col4 $title4] [overtype::left $col5 $title5] [overtype::left $col6 $title6]" if {!$opt_description} { @@ -747,7 +747,7 @@ namespace eval punk::mix::commandset::project { append msg [string repeat "=" $tablewidth] \n foreach p $col1_dbfiles n $col2items c $col3items pn $col4_pnames pc $col5_pcodes dup $col6_dupids desc $col7_pdescs { - set desclines [split [textutil::adjust $desc -length $widest7] \n] + set desclines [split [textutil::adjust $desc -length $widest7] \n] set desc1 [lindex $desclines 0] append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]\ [overtype::left $col4 $pn] [overtype::left $col5 $pc] [overtype::left $col6 $dup]" @@ -756,20 +756,20 @@ namespace eval punk::mix::commandset::project { } else { append msg " [overtype::left $col7 $desc1]" \n foreach dline [lrange $desclines 1 end] { - append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n + append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n } } - } - return $msg - #return [list_as_lines [lib::get_projects $glob]] + } + return $msg + #return [list_as_lines [lib::get_projects $glob]] } proc cd {{glob {}} args} { dict set args -cd 1 - work $glob {*}$args + work $glob {*}$args } proc work {{glob {}} args} { package require sqlite3 - set db_projects [lib::get_projects $glob] + set db_projects [lib::get_projects $glob] if {[llength $db_projects] == 0} { puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$glob'" return "" @@ -779,22 +779,22 @@ namespace eval punk::mix::commandset::project { set defaults [dict create\ -cd 0\ -detail "\uFFFF"\ - ] + ] set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set opt_cd [dict get $opts -cd] - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set opt_detail [dict get $opts -detail] set opt_detail_explicit_zero 1 ;#default assumption only if {$opt_detail eq "\uFFFF"} { set opt_detail_explicit_zero 0 set opt_detail 0; #default } - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set workdir_dict [dict create] set all_workdirs [list] foreach pinfo $db_projects { - lassign $pinfo fosdb name workdirs + lassign $pinfo fosdb name workdirs foreach wdir $workdirs { dict set workdir_dict $wdir $pinfo lappend all_workdirs $wdir @@ -808,15 +808,15 @@ namespace eval punk::mix::commandset::project { set col_pcodes [list] set col_dupids [list] - set fosdb_count [dict create] + set fosdb_count [dict create] set fosdb_dupset [dict create] set fosdb_cache [dict create] set dupset 0 set rowid 1 foreach wd $workdirs { set wdinfo [dict get $workdir_dict $wd] - lassign $wdinfo fosdb nm siblingworkdirs - dict incr fosdb_count $fosdb + lassign $wdinfo fosdb nm siblingworkdirs + dict incr fosdb_count $fosdb set dbcount [dict get $fosdb_count $fosdb] if {[llength $siblingworkdirs] > 1} { if {![dict exists $fosdb_dupset $fosdb]} { @@ -825,7 +825,7 @@ namespace eval punk::mix::commandset::project { } set dupid "[dict get $fosdb_dupset $fosdb].$dbcount/[llength $siblingworkdirs]" } else { - set dupid "" + set dupid "" } if {$dbcount == 1} { set pname "" @@ -842,7 +842,7 @@ namespace eval punk::mix::commandset::project { puts stderr "!!! error: $errM" } } else { - puts stderr "!!! missing fossil db $fosdb" + puts stderr "!!! missing fossil db $fosdb" } } else { set info [dict get $fosdb_cache $fosdb] @@ -858,7 +858,7 @@ namespace eval punk::mix::commandset::project { set col_states [list] set state_title "" - #if only one set of fossil checkouts in the resultset and opt_detail is 0 and not explicit - retrieve workingdir state for each co + #if only one set of fossil checkouts in the resultset and opt_detail is 0 and not explicit - retrieve workingdir state for each co if {([llength [dict keys $fosdb_cache]] == 1)} { if {!$opt_detail_explicit_zero} { set opt_detail 1 @@ -884,13 +884,13 @@ namespace eval punk::mix::commandset::project { set state_dict [punk::repo::workingdir_state_summary_dict $wd_state] lappend c_rev [string range [dict get $state_dict revision] 0 9] lappend c_rev_iso [dict get $state_dict revision_iso8601] - lappend c_unchanged [dict get $state_dict unchanged] + lappend c_unchanged [dict get $state_dict unchanged] lappend c_changed [dict get $state_dict changed] lappend c_new [dict get $state_dict new] lappend c_missing [dict get $state_dict missing] lappend c_extra [dict get $state_dict extra] puts -nonewline stderr "." - } + } puts -nonewline stderr \n set t0 "Revision" set w0 [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev] {string length $v}]] @@ -913,13 +913,13 @@ namespace eval punk::mix::commandset::project { set t5 "Extr" set w5 [tcl::mathfunc::max {*}[lmap v [concat [list $t5] $c_extra] {string length $v}]] set c5 [string repeat " " $w5] - + set state_title "[overtype::left $c0 $t0] [overtype::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [overtype::right $c1 $u] [overtype::right $c2 $c] [overtype::right $c3 $n] [overtype::right $c4 $m] [overtype::right $c5 $e]" } } - + set msg "" if {$opt_cd} { set title0 "CD" @@ -948,7 +948,7 @@ namespace eval punk::mix::commandset::project { append msg "[overtype::right $col0 $title0] [overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3] [overtype::left $col4 $title4] [overtype::left $col5 $title5]" if {[llength $col_states]} { - set title6 $state_title + set title6 $state_title set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col_states] {string length $v}]] set col6 [string repeat " " $widest6] incr tablewidth [expr {$widest6 + 1}] @@ -965,7 +965,7 @@ namespace eval punk::mix::commandset::project { set wd [punk::ansi::a+ red]$wd[a] } append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode] [overtype::left $col6 $s]" \n - } + } } else { foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes { if {![file exists $wd]} { @@ -973,7 +973,7 @@ namespace eval punk::mix::commandset::project { set wd [punk::ansi::a+ red]$wd[a] } append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode]" \n - } + } } set numrows [llength $col_rowids] if {$opt_cd && $numrows >= 1} { @@ -985,7 +985,7 @@ namespace eval punk::mix::commandset::project { ::cd $workingdir return $workingdir } else { - puts stderr "path $workingdir doesn't appear to exist" + puts stderr "path $workingdir doesn't appear to exist" return [pwd] } } else { @@ -1004,12 +1004,12 @@ namespace eval punk::mix::commandset::project { #*** !doctools #[list_end] [comment {-- end collection namespace definitions --}] } - + namespace eval lib { proc template_tag {tagname} { #todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. #we need to detect presence of tags intended for punk::mix system - #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run + #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run return [string cat % $tagname %] } #get project info only by opening the central confg-db @@ -1032,12 +1032,13 @@ namespace eval punk::mix::commandset::project { set path [string trim [string range $pr 5 end]] set nm [file rootname [file tail $path]] set ckouts [fosconf eval {select name from global_config where value = $path;}] + #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" set checkout_paths [list] #strip "ckout:" foreach ck $ckouts { lappend checkout_paths [string trim [string range $ck 6 end]] } - lappend paths_and_names [list $path $nm $checkout_paths] + lappend paths_and_names [list $path $nm $checkout_paths] } set filtered_list [list] foreach glob $globlist { @@ -1045,16 +1046,14 @@ namespace eval punk::mix::commandset::project { foreach m $matches { if {$m ni $filtered_list} { lappend filtered_list $m - } + } } } set projects [lsort -index 1 $filtered_list] return $projects } - + } - - @@ -1067,15 +1066,10 @@ namespace eval punk::mix::commandset::project { - - - - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm index 73b54874..277e386e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm @@ -24,6 +24,9 @@ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::mix::commandset::repo { namespace export * + + variable PUNKARGS + proc tickets {{project ""}} { #todo set result "" @@ -52,9 +55,9 @@ namespace eval punk::mix::commandset::repo { set repopaths [punk::repo::find_repos [pwd]] set repos [dict get $repopaths repos] if {![llength $repos]} { - append result [dict get $repopaths warnings] + append result [a+ bold yellow][dict get $repopaths warnings][a] } else { - append result [dict get $repopaths warnings] + append result [a+ bold yellow][dict get $repopaths warnings][a] lassign [lindex $repos 0] repopath repotypes if {"fossil" in $repotypes} { append result \n "Fossil repo based at $repopath" @@ -69,6 +72,17 @@ namespace eval punk::mix::commandset::repo { } return $result } + + #punk::args + lappend PUNKARGS [list { + @id -id ::punk::mix::commandset::repo::fossil-move-repository + @cmd -name punk::mix::commandset::repo::fossil-move-repository -help\ + "Move the fossil repository file (usually named with .fossil extension). + This is an interactive function which will prompt for answers on stdin + before proceeding. + The move can be done even if there are open checkouts and will maintain + the link between checkout databases and the repository file." + }] proc fossil-move-repository {{path ""}} { set searchbase [pwd] set projectinfo [punk::repo::find_repos $searchbase] @@ -281,7 +295,7 @@ namespace eval punk::mix::commandset::repo { set ckouts [oldrepo eval {select name from config where name like 'ckout:%'}] oldrepo close if {[llength $ckouts] > 1} { - puts stdout "There are [llength $ckouts] checkouts for the repository you are moving" + puts stdout "There are [llength $ckouts] checkouts for the repository you are moving" puts stdout "You will be asked for each checkout if you want to adjust it to point to $target_repodb_folder/$pname2.folder" } set original_cwd [pwd] @@ -304,11 +318,11 @@ namespace eval punk::mix::commandset::repo { puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" puts stderr "$moveresult" } else { - puts stdout "OK - move performed with result:" + puts stdout "OK - move performed with result:" puts stdout $moveresult } } - } + } cd $original_cwd } @@ -379,7 +393,7 @@ namespace eval punk::mix::commandset::repo { puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" puts stderr "$moveresult" } else { - puts stdout "OK - move performed with result:" + puts stdout "OK - move performed with result:" puts stdout $moveresult } } @@ -402,10 +416,10 @@ namespace eval punk::mix::commandset::repo { - - - - +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::mix::commandset::repo +} @@ -413,9 +427,9 @@ namespace eval punk::mix::commandset::repo { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates/utility/a b/tcltest.bat b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates/utility/a b/tcltest.bat deleted file mode 100644 index b75201df..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates/utility/a b/tcltest.bat +++ /dev/null @@ -1,7 +0,0 @@ -::lindex tcl;#\ -@call tclsh "%~dp0%~n0.bat" %* & goto :eof -# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl -puts stdout "script: [info script]" -puts stdout "argv: $::argc" -puts stdout "args: '$::argv'" - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.tm index 58906c88..26ed2f2e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.tm @@ -1,164 +1,163 @@ -#punkapps app manager -# deck cli - -namespace eval punk::mod::cli { - namespace export help list run - namespace ensemble create - - # namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown - if 0 { - proc _unknown {ns args} { - puts stderr "punk::mod::cli::_unknown '$ns' '$args'" - puts stderr "punk::mod::cli::help $args" - puts stderr "arglen:[llength $args]" - punk::mod::cli::help {*}$args - } - } - - #cli must have _init method - usually used to load commandsets lazily - # - variable initialised 0 - proc _init {args} { - variable initialised - if {$initialised} { - return - } - #... - set initialised 1 - } - - proc help {args} { - set basehelp [punk::mix::base help {*}$args] - #namespace export - return $basehelp - } - proc getraw {appname} { - upvar ::punk::config::running running_config - set app_folders [dict get $running_config apps] - #todo search each app folder - set bases [::list] - set versions [::list] - set mains [::list] - set appinfo [::list bases {} mains {} versions {}] - - foreach containerfolder $app_folders { - lappend bases $containerfolder - if {[file exists $containerfolder]} { - if {[file exists $containerfolder/$appname/main.tcl]} { - #exact match - only return info for the exact one specified - set namematches $appname - set parts [split $appname -] - } else { - set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] - set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? - } - foreach nm $namematches { - set mainfile $containerfolder/$nm/main.tcl - set parts [split $nm -] - if {[llength $parts] == 1} { - set ver "" - } else { - set ver [lindex $parts end] - } - if {$ver ni $versions} { - lappend versions $ver - lappend mains $ver $mainfile - } else { - puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" - } - } - } else { - puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" - } - } - dict set appinfo versions $versions - #todo - natsort! - set sorted_versions [lsort $versions] - set latest [lindex $sorted_versions 0] - if {$latest eq "" && [llength $sorted_versions] > 1} { - set latest [lindex $sorted_versions 1 - } - dict set appinfo latest $latest - - dict set appinfo bases $bases - dict set appinfo mains $mains - return $appinfo - } - - proc list {{glob *}} { - upvar ::punk::config::running running_config - set apps_folder [dict get $running_config apps] - if {[file exists $apps_folder]} { - if {[file exists $apps_folder/$glob]} { - #tailcall source $apps_folder/$glob/main.tcl - return $glob - } - set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] - if {[llength $apps] == 0} { - if {[string first * $glob] <0 && [string first ? $glob] <0} { - #no glob chars supplied - only launch if exact match for name part - set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] - set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? - if {[llength $namematches] > 0} { - set latest [lindex $namematches end] - lassign $latest nm ver - #tailcall source $apps_folder/$latest/main.tcl - } - } - } - - return $apps - } - } - - #todo - way to launch as separate process - # solo-opts only before appname - args following appname are passed to the app - proc run {args} { - set nameposn [lsearch -not $args -*] - if {$nameposn < 0} { - error "punkapp::run unable to determine application name" - } - set appname [lindex $args $nameposn] - set controlargs [lrange $args 0 $nameposn-1] - set appargs [lrange $args $nameposn+1 end] - - set appinfo [punk::mod::cli::getraw $appname] - if {[llength [dict get $appinfo versions]]} { - set ver [dict get $appinfo latest] - puts stdout "info: $appinfo" - set ::argc [llength $appargs] - set ::argv $appargs - source [dict get $appinfo mains $ver] - if {"-hideconsole" in $controlargs} { - puts stderr "attempting console hide" - #todo - something better - a callback when window mapped? - after 500 {::punkapp::hide_console} - } - return $appinfo - } else { - error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" - } - } - - -} - -namespace eval punk::mod::cli { - proc _cli {args} { - #don't use tailcall - base uses info level to determine caller - ::punk::mix::base::_cli {*}$args - } - variable default_command help - package require punk::mix::base - package require punk::overlay - punk::overlay::custom_from_base [namespace current] ::punk::mix::base -} - -package provide punk::mod [namespace eval punk::mod { - variable version - set version 0.1 - -}] - - - +#punkapps app manager +# deck cli + +namespace eval punk::mod::cli { + namespace export help list run + namespace ensemble create + + # namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown + if 0 { + proc _unknown {ns args} { + puts stderr "punk::mod::cli::_unknown '$ns' '$args'" + puts stderr "punk::mod::cli::help $args" + puts stderr "arglen:[llength $args]" + punk::mod::cli::help {*}$args + } + } + + #cli must have _init method - usually used to load commandsets lazily + # + variable initialised 0 + proc _init {args} { + variable initialised + if {$initialised} { + return + } + #... + set initialised 1 + } + + proc help {args} { + set basehelp [punk::mix::base help {*}$args] + #namespace export + return $basehelp + } + proc getraw {appname} { + upvar ::punk::config::running running_config + set app_folders [dict get $running_config apps] + #todo search each app folder + set bases [::list] + set versions [::list] + set mains [::list] + set appinfo [::list bases {} mains {} versions {}] + + foreach containerfolder $app_folders { + lappend bases $containerfolder + if {[file exists $containerfolder]} { + if {[file exists $containerfolder/$appname/main.tcl]} { + #exact match - only return info for the exact one specified + set namematches $appname + set parts [split $appname -] + } else { + set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + } + foreach nm $namematches { + set mainfile $containerfolder/$nm/main.tcl + set parts [split $nm -] + if {[llength $parts] == 1} { + set ver "" + } else { + set ver [lindex $parts end] + } + if {$ver ni $versions} { + lappend versions $ver + lappend mains $ver $mainfile + } else { + puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" + } + } + } else { + puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" + } + } + dict set appinfo versions $versions + #todo - natsort! + set sorted_versions [lsort $versions] + set latest [lindex $sorted_versions 0] + if {$latest eq "" && [llength $sorted_versions] > 1} { + set latest [lindex $sorted_versions 1] + } + dict set appinfo latest $latest + + dict set appinfo bases $bases + dict set appinfo mains $mains + return $appinfo + } + + proc list {{glob *}} { + upvar ::punk::config::running running_config + set apps_folder [dict get $running_config apps] + if {[file exists $apps_folder]} { + if {[file exists $apps_folder/$glob]} { + #tailcall source $apps_folder/$glob/main.tcl + return $glob + } + set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] + if {[llength $apps] == 0} { + if {[string first * $glob] <0 && [string first ? $glob] <0} { + #no glob chars supplied - only launch if exact match for name part + set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + if {[llength $namematches] > 0} { + set latest [lindex $namematches end] + lassign $latest nm ver + #tailcall source $apps_folder/$latest/main.tcl + } + } + } + + return $apps + } + } + + #todo - way to launch as separate process + # solo-opts only before appname - args following appname are passed to the app + proc run {args} { + set nameposn [lsearch -not $args -*] + if {$nameposn < 0} { + error "punkapp::run unable to determine application name" + } + set appname [lindex $args $nameposn] + set controlargs [lrange $args 0 $nameposn-1] + set appargs [lrange $args $nameposn+1 end] + + set appinfo [punk::mod::cli::getraw $appname] + if {[llength [dict get $appinfo versions]]} { + set ver [dict get $appinfo latest] + puts stdout "info: $appinfo" + set ::argc [llength $appargs] + set ::argv $appargs + source [dict get $appinfo mains $ver] + if {"-hideconsole" in $controlargs} { + puts stderr "attempting console hide" + #todo - something better - a callback when window mapped? + after 500 {::punkapp::hide_console} + } + return $appinfo + } else { + error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" + } + } + + +} + +namespace eval punk::mod::cli { + proc _cli {args} { + #don't use tailcall - base uses info level to determine caller + ::punk::mix::base::_cli {*}$args + } + variable default_command help + package require punk::mix::base + package require punk::overlay + punk::overlay::custom_from_base [namespace current] ::punk::mix::base +} + +package provide punk::mod [namespace eval punk::mod { + variable version + set version 0.1 +}] + + + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index f0a4a444..1ddd56b7 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -657,6 +657,7 @@ namespace eval punk::path { **/_aside (exlude files where _aside is last segment) **/_aside/* (exclude folders one below an _aside folder) **/_aside/** (exclude all folders with _aside as a segment)" + -antiglob_files -default {} @values -min 0 -max -1 -optional 1 -type string tailglobs -default * -multiple 1 -help\ "Patterns to match against filename portion (last segment) of each file path @@ -681,6 +682,7 @@ namespace eval punk::path { set tailglobs [dict get $values tailglobs] # -- --- --- --- --- --- --- set opt_antiglob_paths [dict get $opts -antiglob_paths] + set opt_antiglob_files [dict get $opts -antiglob_files] set CALLDEPTH [dict get $opts -call-depth-internal] # -- --- --- --- --- --- --- # -- --- --- --- --- --- --- @@ -718,7 +720,24 @@ namespace eval punk::path { puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" set dirfiles [list] } else { - set dirfiles [lsort $matches] + set retained [list] + if {[llength $opt_antiglob_files]} { + foreach m $matches { + set skip 0 + set ftail [file tail $m] + foreach anti $opt_antiglob_files { + if {[string match $anti $ftail]} { + set skip 1; break + } + } + if {!$skip} { + lappend retained $m + } + } + } else { + set retained $matches + } + set dirfiles [lsort $retained] } lappend files {*}$dirfiles diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index f53a06fd..a39fceaf 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -39,16 +39,16 @@ if {$::tcl_platform(platform) eq "windows"} { } package require fileutil; #tcllib package require punk::path -package require punk::mix::base ;#uses core functions from punk::mix::base::lib namespace e.g cksum_path +package require punk::mix::base ;#uses core functions from punk::mix::base::lib namespace e.g cksum_path package require punk::mix::util ;#do_in_path # -- --- --- --- --- --- --- --- --- --- --- # For performance/efficiency reasons - use file functions on paths in preference to string operations -# e.g use file join +# e.g use file join # branch to avoid unnecessary calls to 'pwd' or 'file normalize' - which can be surprisingly expensive operations (as at tcl 8.7 2023) # pwd is only expensive if we treat it as a string instead of a list/path -# e.g +# e.g # > time {set x [pwd]} # 5 microsoeconds.. no problem # > time {set x [pwd]} @@ -67,11 +67,11 @@ namespace eval punk::repo { variable cached_command_paths set cached_command_paths [dict create] - #anticipating possible removal of buggy caching from auto_execok + #anticipating possible removal of buggy caching from auto_execok #mentioned in: https://core.tcl-lang.org/tcl/tktview/4dc35e0c0c #this would leave the application to decide what it wants to cache in that regard. proc Cached_auto_execok {name} { - return [auto_execok $name] + return [auto_execok $name] #variable cached_command_paths #if {[dict exists $cached_command_paths $name]} { # return [dict get $cached_command_paths $name] @@ -102,14 +102,14 @@ namespace eval punk::repo { "" {${$othercmds}} } }] - + return $result } #lappend PUNKARGS [list { # @dynamic - # @id -id ::punk::repo::fossil_proxy + # @id -id ::punk::repo::fossil_proxy # @cmd -name fossil -help "fossil executable # " # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} @@ -117,7 +117,7 @@ namespace eval punk::repo { lappend PUNKARGS [list { @dynamic - @id -id ::punk::repo::fossil_proxy + @id -id ::punk::repo::fossil_proxy @cmd -name fossil -help "fossil executable" ${[punk::repo::get_fossil_usage]} } ] @@ -128,14 +128,13 @@ namespace eval punk::repo { lappend PUNKARGS [list { @dynamic @id -id "::punk::repo::fossil_proxy diff" - @cmd -name "fossil diff" -help "fossil diff - " + @cmd -name "fossil diff" -help "fossil diff" @argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} } ""] lappend PUNKARGS [list { #todo - remove this comment - testing dynamic directive - @dynamic - @id -id "::punk::repo::fossil_proxy add" + @dynamic + @id -id "::punk::repo::fossil_proxy add" @cmd -name "fossil add" -help "fossil add " @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} @@ -152,16 +151,16 @@ namespace eval punk::repo { lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} - #Todo - investigate proper way to install a client-side commit hook in the fossil project + #Todo - investigate proper way to install a client-side commit hook in the fossil project #Then we may still use this proxy to check the hook - but the required checks will occur when another shell used proc fossil_proxy {args} { set start_dir [pwd] - set fosroot [find_fossil $start_dir] + set fosroot [find_fossil $start_dir] set fossilcmd [lindex $args 0] set no_warning_commands [list "help" "dbstat" "grep" "diff" "xdiff" "cat" "version"] if {$fossilcmd ni $no_warning_commands } { - set repostate [find_repos $start_dir] + set repostate [find_repos $start_dir] } set no_prompt_commands [list "status" "info" {*}$no_warning_commands] @@ -170,7 +169,7 @@ namespace eval punk::repo { if {$fossilcmd ni $no_prompt_commands} { set fossilrepos [dict get $repostate fossil] if {[llength $fossilrepos] > 1} { - puts stdout [dict get $repostate warnings] + puts stdout [punk::ansi::a+ bold yellow][dict get $repostate warnings][punk::ansi::a] puts stdout "Operating on inner fossil repository: [lindex $fossilrepos 0]" puts stdout "Use FOSSIL instead of fossil to avoid this prompt and warning" set answer [askuser "Are you sure you want to perform the operation on this repo? Y/N"] @@ -217,7 +216,7 @@ namespace eval punk::repo { } } elseif {$fossilcmd in [list "info" "status"]} { #emit warning whether or not multiple fossil repos - puts stdout [dict get $repostate warnings] + puts stdout [punk::ansi::a+ bold yellow][dict get $repostate warnings][punk::ansi::a] } set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog ne ""} { @@ -234,7 +233,7 @@ namespace eval punk::repo { #safe interps can't call auto_execok #At least let them load the package even though much of it may be unusable depending on the safe configuration #catch { - # if {[auto_execok fossil] ne ""} { + # if {[auto_execok fossil] ne ""} { # interp alias "" FOSSIL "" {*}[auto_execok fossil] # } #} @@ -245,7 +244,7 @@ namespace eval punk::repo { #uppercase FOSSIL to bypass fossil as alias to fossil_proxy #only necessary on unix? - #Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway + #Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway proc establish_FOSSIL {args} { #review if {![info exists ::auto_execs(FOSSIL)]} { @@ -298,7 +297,7 @@ namespace eval punk::repo { if {$path eq {}} { set path [pwd] } scanup $path is_fossil_root } - + proc find_git {{path {}}} { if {$path eq {}} { set path [pwd] } scanup $path is_git_root @@ -330,12 +329,31 @@ namespace eval punk::repo { } } } + lappend PUNKARGS [list { + @id -id "::punk::repo::find_project" + @cmd -name "punk::repo::find_project" -help\ + "Find and return the path for the root of + the project to which the supplied path belongs. + If the supplied path is empty, the current + working directory is used as the starting point + for the upwards search. + Returns nothing if there is no project at or + above the specified path." + @values -min 0 -max 1 + path -optional 1 -default "" -help\ + "May be an absolute or relative path. + The full specified path doesn't have + to exist. The code will walk upwards + along the segments of the supplied path + testing the result of 'is_project_root'." + }] proc find_project {{path {}}} { if {$path eq {}} { set path [pwd] } - scanup $path is_project_root + scanup $path is_project_root } - proc is_fossil_root {{path {}}} { + #detect if path is a fossil root - without consulting fossil databases + proc is_fossil_root2 {{path {}}} { if {$path eq {}} { set path [pwd] } #from kettle::path::is.fossil foreach control { @@ -348,20 +366,51 @@ namespace eval punk::repo { } return 0 } - + proc is_fossil_root {{path {}}} { + #much faster on windows than 'file exists' checks + if {$path eq {}} { set path [pwd] } + set control [list _FOSSIL_ .fslckout .fos] + #could be marked 'hidden' on windows + if {"windows" eq $::tcl_platform(platform)} { + set files [list {*}[glob -nocomplain -dir $path -types f -tail {*}$control] {*}[glob -nocomplain -dir $path -types {f hidden} -tail {*}$control]] + } else { + set files [glob -nocomplain -dir $path -types f -tail {*}$control] + } + expr {[llength $files] > 0} + } + #review - is a .git folder sufficient? #consider git rev-parse --git-dir ? proc is_git_root {{path {}}} { if {$path eq {}} { set path [pwd] } - set control [file join $path .git] - expr {[file exists $control] && [file isdirectory $control]} + #set control [file join $path .git] + #expr {[file exists $control] && [file isdirectory $control]} + if {"windows" eq $::tcl_platform(platform)} { + #:/ + #globbing for dotfiles in tcl is problematic across platforms - windows 'hidden' concept is independent + #we need to find .git whether hidden or not - so need 2 glob operations + #.git may or may not be set with windows 'hidden' attribute + set hiddengitdir [glob -nocomplain -dir $path -types {d hidden} -tail .git] + set nonhiddengitdir [glob -nocomplain -dir $path -types {d} -tail .git] ;#won't return hidden :/ + return [expr {[llength [list {*}$hiddengitdir {*}$nonhiddengitdir]] > 0}] + } else { + #:/ + #unix returns 'hidden' files even without the hidden type being specified - but only if the pattern explicitly matches + return [expr {[llength [glob -nocomplain -dir $path -types d -tail .git]] > 0}] ;#will return .git even though it is conventionally 'hidden' on unix :/ + } } proc is_repo_root {{path {}}} { if {$path eq {}} { set path [pwd] } - expr {[is_fossil_root $path] || [is_git_root $path]} + #expr {[is_fossil_root $path] || [is_git_root $path]} + expr {[is_git_root $path] || [is_fossil_root $path]} ;#is_git_root has less to check } - #require a minimum of src and src/modules|src/scriptapps|src/*/*.vfs - and that it's otherwise sensible - #we still run a high chance of picking up unintended candidates - but hopefully it's a reasonable balance. + + #after excluding undesirables; + #require a minimum of + # - (src and src/modules|src/scriptapps|src/vfs) + # - OR (src and punkproject.toml) + # - and that it's otherwise sensible + #we still run a chance of picking up unintended candidates - but hopefully it's a reasonable balance. proc is_candidate_root {{path {}}} { if {$path eq {}} { set path [pwd] } if {[file pathtype $path] eq "relative"} { @@ -380,24 +429,34 @@ namespace eval punk::repo { } #review - adjust to allow symlinks to folders? - foreach required { - src - } { - set req $path/$required - if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0} + #foreach required { + # src + #} { + # set req $path/$required + # if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0} + #} + set required [list src] + set found_required [glob -nocomplain -dir $path -types d -tails {*}$required] + if {[llength $found_required] < [llength $required]} { + return 0 } set src_subs [glob -nocomplain -dir $path/src -types d -tail *] #test for $path/src/lib is too common to be a useful indicator - if {"modules" in $src_subs || "scriptapps" in $src_subs} { + if {"modules" in $src_subs || "vfs" in $src_subs || "scriptapps" in $src_subs} { + #bare minimum 1 return 1 } - foreach sub $src_subs { - if {[string match *.vfs $sub]} { - return 1 - } + + #bare minimum2 + # - has src folder and (possibly empty?) punkproject.toml + if {[file exists $path/punkproject.toml]} { + return 1 } + #review - do we need to check if path is already within a project? + #can we have a nested project? Seems like asking for complexity and problems when considering possible effects for git/fossil + #todo - breadth first search with depth limit (say depth 3?) for *.tm or *.tcl as another positive qualifier for this dir to be a project-root #we probably don't want to deep search a src folder in case the user is accidentally in some other type of project's tree #such a src tree could be very large, so if we don't find tcl indicators near the root it's a good bet this isn't a candidate @@ -415,14 +474,22 @@ namespace eval punk::repo { } proc is_project_root {path} { - #review - find a reliable simple mechanism. Noting we have projects based on different templates. + #review - find a reliable simple mechanism. Noting we have projects based on different templates. #Should there be a specific required 'project' file of some sort? + #(punkproject.toml is a candidate) + #we don't want to solely rely on such a file being present + # - we may also have punkproject.toml in project_layout template folders for example #test for file/folder items indicating fossil or git workdir base - if {(![punk::repo::is_fossil_root $path]) && (![punk::repo::is_git_root $path])} { + #the 'dev' mechanism for creating projects automatically creates a fossil project + #(which can be ignored if the user wants to manage it with git - but should probably remain in place? review) + #however - we currently require that for it to be a 'project' there must be some version control. + #REVIEW. + # + if {![punk::repo::is_repo_root $path]} { return 0 } - #exclude some known places we wouldn't want to put a project + #exclude some known places we wouldn't want to put a project if {![is_candidate_root $path]} { return 0 } @@ -456,7 +523,7 @@ namespace eval punk::repo { if {$abspath in [dict keys $defaults]} { set args [list $abspath {*}$args] set abspath "" - } + } set opts [dict merge $defaults $args] # -- --- --- --- --- --- --- --- --- --- --- --- set opt_repotypes [dict get $opts -repotypes] @@ -793,7 +860,7 @@ namespace eval punk::repo { } } if {$repotype eq "git"} { - dict set fieldnames extra "extra (files/folders)" + dict set fieldnames extra "extra (files/folders)" } set col1_fields [list] set col2_values [list] @@ -846,6 +913,7 @@ namespace eval punk::repo { #determine nature of possibly-nested repositories (of various types) at and above this path #Treat an untracked 'candidate' folder as a sort of repository proc find_repos {path} { + puts "find_repos '$path'" set start_dir $path #root is a 'project' if it it meets the candidate requrements and is under repo control @@ -860,6 +928,10 @@ namespace eval punk::repo { while {[string length [set fosroot [punk::repo::find_fossil $fos_search_from]]]} { lappend fossils_bottom_to_top $fosroot set fos_search_from [file dirname $fosroot] + if {$fos_search_from eq $fosroot} { + #root of filesystem is repo - unusual case - but without this we would never escape the while loop + break + } } dict set root_dict fossil $fossils_bottom_to_top @@ -868,6 +940,9 @@ namespace eval punk::repo { while {[string length [set gitroot [punk::repo::find_git $git_search_from]]]} { lappend gits_bottom_to_top $gitroot set git_search_from [file dirname $gitroot] + if {$git_search_from eq $gitroot} { + break + } } dict set root_dict git $gits_bottom_to_top @@ -876,6 +951,9 @@ namespace eval punk::repo { while {[string length [set candroot [punk::repo::find_candidate $cand_search_from]]]} { lappend candidates_bottom_to_top $candroot set cand_search_from [file dirname $candroot] + if {$cand_search_from eq $candroot} { + break + } } dict set root_dict candidate $candidates_bottom_to_top @@ -936,14 +1014,14 @@ namespace eval punk::repo { dict set root_dict closest [lindex $longest_first 0 1] ;#the *path* of the closest to start_dir dict set root_dict closest_types [lindex $longest_first 0 0] } - - set closest_fossil [lindex [dict get $root_dict fossil] 0] - set closest_fossil_len [llength [file split $closest_fossil]] - set closest_git [lindex [dict get $root_dict git] 0] - set closest_git_len [llength [file split $closest_git]] - set closest_candidate [lindex [dict get $root_dict candidate] 0] - set closest_candidate_len [llength [file split $closest_candidate]] + + set closest_fossil [lindex [dict get $root_dict fossil] 0] + set closest_fossil_len [llength [file split $closest_fossil]] + set closest_git [lindex [dict get $root_dict git] 0] + set closest_git_len [llength [file split $closest_git]] + set closest_candidate [lindex [dict get $root_dict candidate] 0] + set closest_candidate_len [llength [file split $closest_candidate]] if {$closest_candidate_len > $closest_fossil_len && $closest_candidate_len > $closest_git_len} { #only warn if this candidate is *within* a found repo root @@ -1079,7 +1157,7 @@ namespace eval punk::repo { } if {$opt_ansi} { if {$opt_ansi_prompt eq "\uFFFF"} { - set ansiprompt [a+ green bold] + set ansiprompt [a+ green bold] } else { set ansiprompt [$opt_ansi_prompt] } @@ -1112,15 +1190,15 @@ namespace eval punk::repo { #Whilst it might detect a central repo folder in a non-standard location - it might also be annoying. #Todo - a separate environment variable for users to declare one or more locations where they would like to store project .fossil repositories? - set candidate_repo_folder_locations [list] + set candidate_repo_folder_locations [list] #- choose a sensible default based on where fossil put the global config dir - or on the existence of a .fossils folder in a 'standard' location #verify with user before creating a .fossils folder #always check env(FOSSIL_HOME) first - but this is designed to locate the global .fossil (or _fossil) file - .fossils repository folder doesn't have to be at the same location set usable_repo_folder_locations [list] - #If we find one, but it's not writable - add it to another list + #If we find one, but it's not writable - add it to another list set readonly_repo_folder_locations [list] - #Examine a few possible locations for .fossils folder set + #Examine a few possible locations for .fossils folder set #if containing folder is writable add to candidate list set testpaths [list] @@ -1129,8 +1207,8 @@ namespace eval punk::repo { if {![catch {package require Tcl 8.7-}]} { set fossilhome [file normalize [file tildeexpand $fossilhome_raw]] } else { - #8.6 - set fossilhome [file normalize $fossilhome_raw] + #8.6 + set fossilhome [file normalize $fossilhome_raw] } lappend testpaths [file join $fossilhome .fossils] @@ -1175,13 +1253,13 @@ namespace eval punk::repo { } } } - + set startdir_fossils [glob -nocomplain -dir $startdir -type f *.fossil] if {[llength $startdir_fossils]} { #user is already keeping .fossil files directly in curent dir - give them the option to easily keep doing this #(we don't add it if no .fossil files there already - as it is probably a niche requirement - or a sign the user hasn't thought about a better/central location) if {$startdir ni $usable_repo_folder_locations} { - lappend usable_repo_folder_locations $startdir + lappend usable_repo_folder_locations $startdir } } set choice_folders [list] @@ -1207,7 +1285,7 @@ namespace eval punk::repo { #no existing writable .fossil folders (and no existing .fossil files in startdir) #offer the (writable) candidate_repo_folder_locations foreach fld $candidate_repo_folder_locations { - lappend choice_folders [list index $i folder $fld folderexists 0 existingfossils "" conflict ""] + lappend choice_folders [list index $i folder $fld folderexists 0 existingfossils "" conflict ""] incr i } } @@ -1230,7 +1308,7 @@ namespace eval punk::repo { } set folderexists [dict get $option folderexists] if {$folderexists} { - set folderstatus "(existing folder)" + set folderstatus "(existing folder)" } else { set folderstatus "(CREATE folder for .fossil repository files)" } @@ -1238,7 +1316,7 @@ namespace eval punk::repo { } - #append the readonly_repo_folder_locations so that user is aware of them as it may affect their choice + #append the readonly_repo_folder_locations so that user is aware of them as it may affect their choice if {[llength $readonly_repo_folder_locations]} { append menu_message "--------------------------------------------------" \n foreach readonly $readonly_repo_folder_locations { @@ -1256,11 +1334,11 @@ namespace eval punk::repo { } else { if {[llength $choice_folders] || $opt_askpath} { puts stdout $menu_message - set max [llength $choice_folders] + set max [llength $choice_folders] if {$max == 1} { set rangemsg "the number 1" } else { - set rangemsg "a number from 1 to $max" + set rangemsg "a number from 1 to $max" } set menuprompt "${ansiprompt}Enter $rangemsg to select location. (or N to abort)${ansireset}" if {$opt_askpath} { @@ -1279,7 +1357,7 @@ namespace eval punk::repo { set answer [askuser "${ansiprompt}Do you want to create this folder? Type just the word mkdir to create it, or N for no${ansireset}"] if {[string equal mkdir [string tolower $answer]]} { if {[catch {file mkdir $repository_folder} errM]} { - puts stderr "Failed to create folder $repository_folder. Error $errM" + puts stderr "Failed to create folder $repository_folder. Error $errM" } } } else { @@ -1317,7 +1395,7 @@ namespace eval punk::repo { if {$index >= 0 && $index <= $max-1} { set repo_folder_choice [lindex $choice_folders $index] set repository_folder [dict get $repo_folder_choice folder] - puts stdout "Selected fossil location $repository_folder" + puts stdout "Selected fossil location $repository_folder" } else { puts stderr " No menu number matched - aborting." return @@ -1367,7 +1445,7 @@ namespace eval punk::repo { proc fossil_revision {{path {}}} { if {$path eq {}} { set path [pwd] } - # ::kettle::path::revision.fossil + # ::kettle::path::revision.fossil set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { @@ -1381,7 +1459,7 @@ namespace eval punk::repo { proc fossil_remote {{path {}}} { if {$path eq {}} { set path [pwd] } - # ::kettle::path::revision.fossil + # ::kettle::path::revision.fossil set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { @@ -1395,11 +1473,11 @@ namespace eval punk::repo { proc fossil_get_configdb {{path {}}} { #fossil info will *usually* give us the necessary config-db info whether in a project folder or not but.. #a) It's expensive to shell-out and call it - #b) it won't give us a result if we are in a checkout folder which has had its repository moved + #b) it won't give us a result if we are in a checkout folder which has had its repository moved #this fairly extensive mechanism is designed to find it even if the environment has some weird goings-on regarding the filesystem/environment variables #This is unlikely to be necessary in most scenarios, where the location is related to the user's home directory - - #attempt 1 - environment vars and well-known locations + + #attempt 1 - environment vars and well-known locations #This is first because it's faster - but hopefully it's aligned with how fossil does it if {"windows" eq $::tcl_platform(platform)} { @@ -1416,7 +1494,7 @@ namespace eval punk::repo { if {[file exists $testfile]} { return $testfile } - } + } } else { foreach varname [list FOSSIL_HOME HOME ] { if {[info exists ::env($varname)]} { @@ -1435,13 +1513,13 @@ namespace eval punk::repo { if {[file exists $testfile]} { return $testfile } - } + } if {[info exists ::env(HOME)]} { set testfile [file join $::env(HOME) .config fossil.db] if {[file exists $testfile]} { return $testfile } - } + } } @@ -1484,13 +1562,13 @@ namespace eval punk::repo { cd $original_cwd } - #attempt 3 - getting desperate.. find other repos, determine their checkouts and run fossil in them to get a result + #attempt 3 - getting desperate.. find other repos, determine their checkouts and run fossil in them to get a result if {$fossil_ok} { #It should be extremely rare to need to resort to sqlite on the databases to find other potential repo paths #Conceivably only on some weird VFS or where some other filesystem strangeness is going on with our original path - or if the root volume itself is a broken fossil checkout #Examining the other repos gives us a chance at discovering some other filesystem/paths where things may not be broken if {![catch {package require sqlite3} errPackage]} { - #use fossil all ls and sqlite + #use fossil all ls and sqlite if {[catch {exec {*}$fossilcmd all ls} repolines]} { error "fossil_get_configdb cannot find repositories" } else { @@ -1535,7 +1613,7 @@ namespace eval punk::repo { error "fossil_get_configdb exhausted search options" } #------------------------------------ - + #temporarily cd to workpath to run script - return to correct path even on failure proc do_in_path {path script} { #from ::kettle::path::in @@ -1611,8 +1689,8 @@ namespace eval punk::repo { set platform $::tcl_platform(platform) } - #No - don't do this sort of path translation here - leave as option for specific utils only such as ./ - #Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work + #No - don't do this sort of path translation here - leave as option for specific utils only such as ./ + #Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work #We shouldn't break it totally just because accessing WSL/mingw paths is slightly more useful #if {$platform eq "windows"} { #return [file dirname [file normalize [punk::unixywindows::towinpath $path]/__]] @@ -1624,7 +1702,7 @@ namespace eval punk::repo { #This taken from kettle::path::strip #It doesn't compare the prefix contents presumably for speed when used in kettle::path::scan #renamed to better indicate its behaviour - + proc path_strip_prefixdepth {path prefix} { if {$prefix eq ""} { return [norm $path] @@ -1713,9 +1791,9 @@ namespace eval ::punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::repo [namespace eval punk::repo { variable version - set version 0.1.1 + set version 0.1.1 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkapp-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkapp-0.1.tm index ce46856b..70fa90fc 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkapp-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkapp-0.1.tm @@ -1,239 +1,239 @@ -#utilities for punk apps to call - -package provide punkapp [namespace eval punkapp { - variable version - set version 0.1 -}] - -namespace eval punkapp { - variable result - variable waiting "no" - proc hide_dot_window {} { - #alternative to wm withdraw . - #see https://wiki.tcl-lang.org/page/wm+withdraw - wm geometry . 1x1+0+0 - wm overrideredirect . 1 - wm transient . - } - proc is_toplevel {w} { - if {![llength [info commands winfo]]} { - return 0 - } - expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} - } - proc get_toplevels {{w .}} { - if {![llength [info commands winfo]]} { - return [list] - } - set list {} - if {[is_toplevel $w]} { - lappend list $w - } - foreach w [winfo children $w] { - lappend list {*}[get_toplevels $w] - } - return $list - } - - proc make_toplevel_next {prefix} { - set top [get_toplevel_next $prefix] - return [toplevel $top] - } - #possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime - #todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? - #can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix - proc get_toplevel_next {prefix} { - set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" - - - - } - proc exit {{toplevel ""}} { - variable waiting - variable result - variable default_result - set toplevels [get_toplevels] - if {[string length $toplevel]} { - set wposn [lsearch $toplevels $toplevel] - if {$wposn > 0} { - destroy $toplevel - } - } else { - #review - if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { - puts stderr "punkapp::exit called without toplevel - showing console" - show_console - return 0 - } else { - puts stderr "punkapp::exit called without toplevel - exiting" - if {$waiting ne "no"} { - if {[info exists result(shell)]} { - set temp [set result(shell)] - unset result(shell) - set waiting $temp - } else { - set waiting "" - } - } else { - ::exit - } - } - } - - set controllable [get_user_controllable_toplevels] - if {![llength $controllable]} { - if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { - show_console - } else { - if {$waiting ne "no"} { - if {[info exists result(shell)]} { - set temp [set result(shell)] - unset result(shell) - set waiting $temp - } elseif {[info exists result($toplevel)]} { - set temp [set result($toplevel)] - unset result($toplevel) - set waiting $temp - } elseif {[info exists default_result]} { - set temp $default_result - unset default_result - set waiting $temp - } else { - set waiting "" - } - } else { - ::exit - } - } - } - } - proc close_window {toplevel} { - wm withdraw $toplevel - if {![llength [get_user_controllable_toplevels]]} { - punkapp::exit $toplevel - } - destroy $toplevel - } - proc wait {args} { - variable waiting - variable default_result - if {[dict exists $args -defaultresult]} { - set default_result [dict get $args -defaultresult] - } - foreach t [punkapp::get_toplevels] { - if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { - wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] - } - } - if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { - puts stderr "repl eventloop seems to be running - punkapp::wait not required" - } else { - if {$waiting eq "no"} { - set waiting "waiting" - vwait ::punkapp::waiting - return $::punkapp::waiting - } - } - } - - #A window can be 'visible' according to this - but underneath other windows etc - #REVIEW - change name? - proc get_visible_toplevels {{w .}} { - if {![llength [info commands winfo]]} { - return [list] - } - set list [get_toplevels $w] - set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] - set mapped [concat {*}$mapped] ;#ignore {} - set visible [list] - foreach m $mapped { - if {[wm overrideredirect $m] == 0 } { - lappend visible $m - } else { - if {[winfo height $m] >1 && [winfo width $m] > 1} { - #technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 - #as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible - lappend visible $m - } - } - } - return $visible - } - proc get_user_controllable_toplevels {{w .}} { - set visible [get_visible_toplevels $w] - set controllable [list] - foreach v $visible { - if {[wm overrideredirect $v] == 0} { - lappend controllable $v - } - } - #only return visible windows with overrideredirect == 0 because there exists some user control. - #todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily - return $controllable - } - proc hide_console {args} { - set opts [dict create -force 0] - if {([llength $args] % 2) != 0} { - error "hide_console expects pairs of arguments. e.g -force 1" - } - #set known_opts [dict keys $defaults] - foreach {k v} $args { - switch -- $k { - -force { - dict set opts $k $v - } - default { - error "Unrecognised options '$k' known options: [dict keys $opts]" - } - } - } - set force [dict get $opts -force] - - if {!$force} { - if {![llength [get_user_controllable_toplevels]]} { - puts stderr "Cannot hide console while no user-controllable windows available" - return 0 - } - } - if {$::tcl_platform(platform) eq "windows"} { - #hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. - #It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. - #an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. - #(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) - package require twapi - set h [twapi::get_console_window] - set pid [twapi::get_window_process $h] - set pinfo [twapi::get_process_info $pid -name] - set pname [dict get $pinfo -name] - set wstyle [twapi::get_window_style $h] - #tclkitsh/tclsh? - if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { - twapi::hide_window $h - return 1 - } else { - puts stderr "punkapp::hide_console unable to hide this type of console window" - return 0 - } - } else { - #todo - puts stderr "punkapp::hide_console unimplemented on this platform (todo)" - return 0 - } - } - - proc show_console {} { - if {$::tcl_platform(platform) eq "windows"} { - package require twapi - if {![catch {set h [twapi::get_console_window]} errM]} { - twapi::show_window $h -activate -normal - } else { - #no console - assume launched from something like wish? - catch {console show} - } - } else { - #todo - puts stderr "punkapp::show_console unimplemented on this platform" - } - } - -} +#utilities for punk apps to call + +package provide punkapp [namespace eval punkapp { + variable version + set version 0.1 +}] + +namespace eval punkapp { + variable result + variable waiting "no" + proc hide_dot_window {} { + #alternative to wm withdraw . + #see https://wiki.tcl-lang.org/page/wm+withdraw + wm geometry . 1x1+0+0 + wm overrideredirect . 1 + wm transient . + } + proc is_toplevel {w} { + if {![llength [info commands winfo]]} { + return 0 + } + expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} + } + proc get_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list {} + if {[is_toplevel $w]} { + lappend list $w + } + foreach w [winfo children $w] { + lappend list {*}[get_toplevels $w] + } + return $list + } + + proc make_toplevel_next {prefix} { + set top [get_toplevel_next $prefix] + return [toplevel $top] + } + #possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime + #todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? + #can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix + proc get_toplevel_next {prefix} { + set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" + + + + } + proc exit {{toplevel ""}} { + variable waiting + variable result + variable default_result + set toplevels [get_toplevels] + if {[string length $toplevel]} { + set wposn [lsearch $toplevels $toplevel] + if {$wposn > 0} { + destroy $toplevel + } + } else { + #review + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "punkapp::exit called without toplevel - showing console" + show_console + return 0 + } else { + puts stderr "punkapp::exit called without toplevel - exiting" + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + + set controllable [get_user_controllable_toplevels] + if {![llength $controllable]} { + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + show_console + } else { + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } elseif {[info exists result($toplevel)]} { + set temp [set result($toplevel)] + unset result($toplevel) + set waiting $temp + } elseif {[info exists default_result]} { + set temp $default_result + unset default_result + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + } + proc close_window {toplevel} { + wm withdraw $toplevel + if {![llength [get_user_controllable_toplevels]]} { + punkapp::exit $toplevel + } + destroy $toplevel + } + proc wait {args} { + variable waiting + variable default_result + if {[dict exists $args -defaultresult]} { + set default_result [dict get $args -defaultresult] + } + foreach t [punkapp::get_toplevels] { + if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { + wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] + } + } + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "repl eventloop seems to be running - punkapp::wait not required" + } else { + if {$waiting eq "no"} { + set waiting "waiting" + vwait ::punkapp::waiting + return $::punkapp::waiting + } + } + } + + #A window can be 'visible' according to this - but underneath other windows etc + #REVIEW - change name? + proc get_visible_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list [get_toplevels $w] + set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] + set mapped [concat {*}$mapped] ;#ignore {} + set visible [list] + foreach m $mapped { + if {[wm overrideredirect $m] == 0 } { + lappend visible $m + } else { + if {[winfo height $m] >1 && [winfo width $m] > 1} { + #technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 + #as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible + lappend visible $m + } + } + } + return $visible + } + proc get_user_controllable_toplevels {{w .}} { + set visible [get_visible_toplevels $w] + set controllable [list] + foreach v $visible { + if {[wm overrideredirect $v] == 0} { + lappend controllable $v + } + } + #only return visible windows with overrideredirect == 0 because there exists some user control. + #todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily + return $controllable + } + proc hide_console {args} { + set opts [dict create -force 0] + if {([llength $args] % 2) != 0} { + error "hide_console expects pairs of arguments. e.g -force 1" + } + #set known_opts [dict keys $defaults] + foreach {k v} $args { + switch -- $k { + -force { + dict set opts $k $v + } + default { + error "Unrecognised options '$k' known options: [dict keys $opts]" + } + } + } + set force [dict get $opts -force] + + if {!$force} { + if {![llength [get_user_controllable_toplevels]]} { + puts stderr "Cannot hide console while no user-controllable windows available" + return 0 + } + } + if {$::tcl_platform(platform) eq "windows"} { + #hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. + #It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. + #an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. + #(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) + package require twapi + set h [twapi::get_console_window] + set pid [twapi::get_window_process $h] + set pinfo [twapi::get_process_info $pid -name] + set pname [dict get $pinfo -name] + set wstyle [twapi::get_window_style $h] + #tclkitsh/tclsh? + if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { + twapi::hide_window $h + return 1 + } else { + puts stderr "punkapp::hide_console unable to hide this type of console window" + return 0 + } + } else { + #todo + puts stderr "punkapp::hide_console unimplemented on this platform (todo)" + return 0 + } + } + + proc show_console {} { + if {$::tcl_platform(platform) eq "windows"} { + package require twapi + if {![catch {set h [twapi::get_console_window]} errM]} { + twapi::show_window $h -activate -normal + } else { + #no console - assume launched from something like wish? + catch {console show} + } + } else { + #todo + puts stderr "punkapp::show_console unimplemented on this platform" + } + } + +} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm index fbf9a4e4..a4113c45 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm @@ -243,12 +243,14 @@ namespace eval punkcheck { } method get_targets_exist {} { set punkcheck_folder [file dirname [$o_installer get_checkfile]] - set existing [list] - foreach t $o_targets { - if {[file exists [file join $punkcheck_folder $t]]} { - lappend existing $t - } - } + set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets] + + #set existing [list] + #foreach t $o_targets { + # if {[file exists [file join $punkcheck_folder $t]]} { + # lappend existing $t + # } + #} return $existing } method end {} { @@ -880,19 +882,46 @@ namespace eval punkcheck { #allow nonexistant as a source set fpath [file join $punkcheck_folder $source_relpath] - if {![file exists $fpath]} { + #windows: file exist + file type = 2ms vs 500ms for 2x glob + set floc [file dirname $fpath] + set fname [file tail $fpath] + set file_set [glob -nocomplain -dir $floc -type f -tails $fname] + set dir_set [glob -nocomplain -dir $floc -type d -tails $fname] + set link_set [glob -nocomplain -dir $floc -type l -tails $fname] + if {[llength $file_set] == 0 && [llength $dir_set] == 0 && [llength $link_set] == 0} { + #could also theoretically exist as less common types, b,c,p,s (block,char,pipe,socket) + #- we don't expect them here - REVIEW - ever possible? + #- installing/examining such things an unlikely usecase and would require special handling anyway. set ftype "missing" set fsize "" } else { - set ftype [file type $fpath] - if {$ftype eq "directory"} { + if {[llength $dir_set]} { + set ftype "directory" set fsize "NA" + } elseif {[llength $link_set]} { + set ftype "link" + set fsize 0 } else { + set ftype "file" #todo - optionally use mtime instead of cksum (for files only)? #mtime is not reliable across platforms and filesystems though.. see article linked at top. set fsize [file size $fpath] } } + + #if {![file exists $fpath]} { + # set ftype "missing" + # set fsize "" + #} else { + # set ftype [file type $fpath] + # if {$ftype eq "directory"} { + # set fsize "NA" + # } else { + # #todo - optionally use mtime instead of cksum (for files only)? + # #mtime is not reliable across platforms and filesystems though.. see article linked at top. + # set fsize [file size $fpath] + # } + #} #get_relativecksum_from_base and fill_relativecksums_from_base_and_relativepathdict will set cksum to if fpath doesn't exist if {$use_cache} { set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $punkcheck_folder [dict create $source_relpath $use_cache_record]] @@ -1648,6 +1677,10 @@ namespace eval punkcheck { set is_skip 0 if {$overwrite_what eq "all-targets"} { file mkdir $current_target_dir + #-------------------------------------------- + #sometimes we get the error: 'error copying "file1" to "file2": invalid argument' + #-------------------------------------------- + puts stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" file copy -force $current_source_dir/$m $current_target_dir lappend files_copied $current_source_dir/$m } else { @@ -1859,22 +1892,75 @@ namespace eval punkcheck { return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged antiglob_paths_matched $antiglob_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] } - proc summarize_install_resultdict {resultdict} { + + + lappend PUNKARGS [list { + @id -id ::punkcheck::summarize_install_resultdict + @cmd -name punkcheck::summarize_install_resultdict -help\ + "Emits a string summarizing a punkcheck resultdict, showing + how many items were copied, and the source, target locations" + @opts + -title -type string -default "" + -forcecolour -type boolean -default 0 -help\ + "When true, passes the forcecolour tag to punk::ansi functions. + This enables ANSI sgr colours even when colour + is off. (ignoring env(NO_COLOR)) + To disable colour - ensure the NO_COLOR env var is set, + or use: + namespace eval ::punk::console {variable colour_disabled 1}" + @values -min 1 -max 1 + resultdict -type dict + }] + proc summarize_install_resultdict {args} { + set argd [punk::args::parse $args withid ::punkcheck::summarize_install_resultdict] + lassign [dict values $argd] leaders opts values received + set title [dict get $opts -title] + set forcecolour [dict get $opts -forcecolour] + set resultdict [dict get $values resultdict] + + set has_ansi [expr {![catch {package require punk::ansi}]}] + if {$has_ansi} { + if {$forcecolour} { + set fc "forcecolour" + } else { + set fc "" + } + set R [punk::ansi::a] ;#reset + set LINE_COLOUR [punk::ansi::a+ {*}$forcecolour bold cyan] + set LOW_COLOUR [punk::ansi::a+ {*}$forcecolour bold green] + set HIGH_COLOUR [punk::ansi::a+ {*}$forcecolour bold yellow] + } else { + set R "" + set LINE_COLOUR "" + set LOW_COLOUR "" + set HIGH_COLOUR "" + } + set msg "" if {[dict size $resultdict]} { set copied [dict get $resultdict files_copied] - append msg "--------------------------" \n - append msg "[dict keys $resultdict]" \n + if {[llength $copied] == 0} { + set HIGHLIGHT $LOW_COLOUR + } else { + set HIGHLIGHT $HIGH_COLOUR + } + set ruler $LINE_COLOUR[string repeat - 78]$R + if {$title ne ""} { + append msg $ruler \n + append msg $title \n + } + append msg $ruler \n + #append msg "[dict keys $resultdict]" \n set tgtdir [dict get $resultdict tgtdir] set checkfolder [dict get $resultdict punkcheck_folder] - append msg "Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]" \n + append msg "${HIGHLIGHT}Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]$R" \n foreach f $copied { append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n append msg " TO $tgtdir" \n } append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n - append msg "--------------------------" \n + append msg $ruler \n } return $msg } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm index 8405fae74a50ec468daaff5adfc86c3c68353219..d365bab1e00edd610a3a4ae19fa00fb3d3e10a44 100644 GIT binary patch delta 8944 zcma)hbzD?i_xCV#cS;Nr(v6gKmvnawUBZBXz|bj(9J;$Z6%=U@R3xQa5D*YS5G39a zz0cM6{_~sp%$!wwt+n@=*=z0Z8QcbU0N_MkI7A!zz}wLi>IH#1!W^KU5NmHo7nq|P z#NW}w&Wi)$?g{a+^AZ(Bun?F##MRx~4F-AW;OGMVY2g92<-&se@nVp6fk8dptYD5l zP!~Ulx7*KgUhWW>gB1({^@Vv_*}$N-5C&IwTMu_zP7i)78)qwfD5nq9)63D_4Pxi+ zVv9(^(F=k|!OO}O`j5oQ3&I6+h1ekiKjop77e!?9(}Sp}i=(xusH>GT)B+L8;+GV{ z>27D|1%<)6qKxRrFl~p?G%>5iu~(NG3`cH5oK2hYCAoiwbI7o;Zp7vqavm1 z{;Z4?S7$OGxg{}F-l|BcNtfgqyHs_0=xSo>r3@)*LGOm zA2O7xSIP(myFIPPCmr|%Si<{zp<1)4Eykdr*}isD4u6JX6}3 zP{9~3Ke`qp2QhW}W_~fLNc&}dU)+Eeu7yfir%R0tJz2$jve9s2Sn->c@&|jicHfJ< zJfyBSN({4QyvdsyXy%RXJ)jhQVo>%VJT9!8<0{6TY;>(0&$~uBg(KDDgDFnb(L%9K zdl-YjJ$mW>Mz#DSxVmTp)$IFsI3uJK4W+ze)x!Knj@b6FN3u?^J6oD#c%|>SrzPYp zP<5Q#yfW11{ap-rrqoDv>C{p*BW84-jGUQn#INb_o}~0z`Uz=s5zogr+kbwiyb!1O zI9+39>mk13Y6&Z86l$i8rqau<{U&A|YbKHyFnc~H>yY)l4qTW2i??f_|5xG0fWBMG z9%fKFeqIqdBz%t3>6IwDo*#qFlqaI$BEf(hW+@?9Z{y4Rxn36&ilWF@REy>oW0NGOlg+i1neF&2^SG>`39)Ke)Z@6jKlBWAp%PT*~kh4q66WT?5I9uCVwbO#MUki|$t`%!P(YZT_{;?u$ zm_lOc#{eAvW5^-=3lh~J1%sTDJpOzLnuH+q`D?j^;30WyGOFIwC#x*UWR_{*cU|HU ztsS7-pE399}w>&9TF!or(suQP_+ww{mxpUuDbqc z{(Y0G!Dr>KAxriax3RqMYD!GbMCOQ2n^zCuS-gZ?5Si>fo2`#}QYH(*P4%Z9XFFvM zfUneE!kb@S?K;6`A1~~O<58ts>h{*P2{DvQz;E|WUix*K;oVwh-qYVh_uXCKdh5Mt z&LF?qfgisATmoLAP@)xB;OEZ`~fC<6omu=jU$6V z+&{M|xGmI&`+>JRVv}};`fxP*@G`^IxHwjuwQN>KZkmW@1)j=zZ~{#}{bl z>TVN9zm=NZo-@Dy>?O_|6{{*oQeNV5!qN~!t{wTF;o?`H{1P)1Y2$_f*Q>4%!BgIF z%oc|Z`(^z_2KVC-@A^=q@^8moMp)y=$O~caDthoH`{zbxjK*!Ai&*f(PaV=M2NeY% z*1_wQBo6h4_SH*HWjfy~wdK0@L0TQg2npXa)rD3gCtUf{&gN;9!m|-rqc2z_S5Zqi z2v1UK_^|4XHYJpBNdEY4hB$akbhJn8bla8;te#@LD1Gv6uXskMSypj#@p(dfP%@@A z$xL7>^A)b<|85~?e4w$9=4rnRqS7?t021_K@Dc-6_w~C35(clVD~CK9%ZV7vWTM2m z=6b>M9pWSjRPTvCmKP{-Dnp4;&JS|vE7G8CtUIzCUUr>lo2;8_*g|BV8JgbnxjOlQ zs;H3kIG=?W_r&YxaMaY!qr(SmW6n)OH(Apn*j`6cx|crR4)>0{h#=K}k;FwY?ZJ`( zg-gnjv#`r;RU7MWozEg+AT856kEoAe?Pn`psZSD#oA0LtqG&yzkXc8DD_nb{s$ce~ zLO6?M65kztdWvBoPk39R0a?-0qQls$K0-?JZY(34AN(Q%bBIs$1l^r*#a_ESOW#qI zZAo}ULO9;O)VY;B`pfv&p08iY)_hr6b>R~%lmy#0&v0X?V2@7Q_ISJoQcazs)k9d@ zpf&t6TGYW$fDyBtO5 z?UO3WOafDf=tb#r@nUVO{2EKcV3I?6k*zc4jEj=gDX@eoaGzG>7#n@`*y1xuBstu- zf7KwBR7K^D1f$m>ueuA6^s38^$Fteq^j;hiL)84mjJi>ljmDUxg#;7VGjHo`RezN| z=eW74^k6?uy{NsXrQ3?%EECTOg3#qPN--{WQJV#gQh z7}o2z7Fs&=hp&%!3PemBQ5!4qJ@u8{Bn#e-3Q*{P-I79_S;`xpeRS|=W?7(jj}c3w zw*E$P+T_92d1MqVwv9H+_87#z+A~v2?Yg*snB3aE?Gt-gNJsa2x7Lzu;%qY%?v1m= z&m*e_lX`lrTRwW0Ef@$sSXNwm*KM?vrgTw#TE!Y3q{S08F_WpHkD+%@>xlr#P}lyr zavcOW)b~iS-Emy~40@!~dY0`P6u0H=y+;fWIJHkT33%vuB3k;9VuD-K&g?Y4dHs6b zzqzE^>Ph^fbGtb0i_3QEdjZl)@KZs&9v*aDJR7}rXPjk1e$T)lNp{Cr%mZVkiw;}* z2kY(ppRfk2tvESF89}$uU!8HgrqH#FX+j72SLE4ocWUq+nmc@o2$1W(EHS3N4f7SX zaMXWhR(1Z~QRP17#J9pGz4LWtOAfZr9{ee`4GMjo0(dU;m^#FqHU$+I67a*ZWBWA> zk-jN@#-{N~zc1W)8%cT1bL*(KcGh}47Z>RF)mMwg*Q3C> z+n(0WcLSy9#R}iSs$pML3NFqG%%$>lp2J}>ehwT-14$HPx|k`jzR-DGal#d-M`L$&q-*b^I5)f=S@lVy?o}A;NFrf&bXjUCs$apL ziqUrC#E2kX$sGRpG}F_Nk6!$PQY}d!n@W^TmtnSC|dw zHD0ekqWgd{)pU>tb>g-KA@R4PM}DtS+X904pIo8+yCEGAnX?(y^x6wbB1()W;-dya z1L)O+fhSq0fH*q=+VwRUQB0cD*-`HjQt$^FBTPUD$<539rcd^0Km*>`5#43r;$pY8 zf?0XNJiTpT-k#9Extr3&WoPB>>*DC<{JTaWg8*SyYJiuM4*2QjOC1*aZw(ORYLCSC zzW`tAPzfz;JYDR#VD7Fi|JZQ5858Rj2K|+kK4Jn|O?1G4FDlUGhR69cEl_LqResNO-VIS3 z0#jdE=X1Qr&XjMH8tajwjdgpEw#Xx^Pzf zg{9(#hZ626J^r9)0!fOBOwT&zF)@;pk~C9Wa?^FRH70t+P;e)zLIHOY;dH!p0Dqnu z-s=3L(n#e>sUKDWa8S4g# zE2f3ylRc4ahifDhtCX|r!<*pvff&uXzPoO1uY}0*Vl0cvi=v`Ap;4{ct4k$}z@9>R}0651e7;Si&xQ7^htxeQ-ur zG*YN`Yu%hkUFCAiCO_<<2j>K>kLcc4F7yDMbL8d5ERmxC>JR%*d`w2wEjKrD&nsJ_ zU;C;(2-sIxex^_((k7mrlcbR%{G_&c=bJ`!`Kg*P{MhcsCjwJ40qd~ z4S=eM+>S?5y}3puvjZ=POUcXfB(lx2Wfn%A$nzw6NE+o!mU^_y$(MD-YS9DrAL-af zL3=oJ9Hytwtm4Su(?|K27z{o&N>(YF3m4kxJ2PFhCArBxgtQ{v9M7 zrP_F9xRKUnSl9)4TF&Xs7C9syBaa*CqQC_7fl%xLOQmG3Bo^9;c2#1Il84Dfnlf%4 zwVXxaDp&A$naq6r$2`NVx=AOV9OaEW{M$ti>q(In)_JUVRaz37XpzLmtQ4~(;eDc1NAfWyR`4tdYNS&0 z8Jo9$_E_~ZH@g)=s0i8=Sl#(hM2VXgLQ&-@>AVV$^I@8NSBqnK=t-|2z7{E5_ zuh9gTjim~47kHSgtkx6=J9eG+ht`z~uw>`p(?tyuQ7a1bMJjncOXf$}6x3r;nZdKM zbKU(4k0OSHzborSqw-Ro zjXu!IzoR@LhxaXGRB3dG=CT>XC&|EB>jlqnng@%q>=;!xvrkfrA?dB>$hX5oi5Q$j zvdzuR%nNdeh)qMxRHl1`RK6`sJy4OYiC)Ki3{OuUkj_rmSoayEX7sFJ>!;R*`x3^315xmF5mw%=pC4crQ|`N?&B<$tQ_X_N;9R zV*0mo(aEy8NaW$l9S=eu;11g1Gif#3YI`+0Y*tf0+vbWUy1(1_yu~(=k5Wr;vM6Sj zGXV}8vh8p(;hDmFvvDzHtL7C^G3v&qVL?5Q9ean_xXBHha=Tanz9v zzPA}7t*f+JWfTBU9}Uw$5)UDGkXYj`Fw89fc*LV9vdy6P+$YbRP@`kfW$NiLzx@T@ z0Nc#C&Xe?eJe3LUon(u+mAUwOuPk!&^2}k)Lws9#f*6%f5wuS^nzxRID{WgJ>R|fA zpZ5dL3DF1M2j3ZdhnIDVoc+DCuH!I|YtX#a&$M$9G}6|h4#gy@B<&?Ypkkxj2lKTu^4sCgNefC~t#K8E+*{Qn$4S$@8?Y9s0WtmIMu}aK8 zVudVJ&khE-9WbT|KG&nLe;xT@l^OI<7QXih9cg!x9e78CJu1(kcDu5qjbYi4k-p{5 z{f&b4JpPICp+r1Xt=F?$0Tc5^LYFZY=U%;Sk?tA;Z7DxyCc!+9s3KF!KhmD1&wr{k zWe45}7}mFR2c@Iqexur<$@cH}X|uXZ9NeO-{jf5|B>8N(;;v z!w-VyQO_HT5!#h=U5uM z=;F#VTa@Xc?XFmY1*1c=WdRn+Ay2-ynNkPb@2hSHj-#AIq9vTxE@DpyQ6HJH>R&w+ zB#f^p{0KLkIH&u!VsjJ+8T1`zKldgeWY5s2PkHYFf1k^&w8rqtTcKS99 zJo@R`UAE(4aO+&?z2(^U#Bvw;Mq8&rpRo%{gN2~&&r*kv<;w`|Wb~f0m0O$%I7PU2m#0P5bSU^-lv^PI&+N$#UQGiY;8_+`RN(;nNpZ)l0i7f(!O zCP?B!mJTjIW1rj-b8*eG2ift;Ce2GvbaWrhX|zsYI-F=Q>n*_ zr9b=`hcvBzTz>zfA--Q9WbENN<$H#>ztX56knl~vhq%A+KbyIn<7;{6>;&~AS88{Xc=pt@d{ajcram2S%FpW=cuT)L0_^BJk7Z7!gO6MoN+1Oxo zt=|fCB&p*w;Crt&V@E-xu)Olw5yYllsA$$iusm*A~EAw7BWhEJ_%K*yDvdqW;q zV|zZfOL@gi-4Bz_%ICdPUwKdG?BM?3(E=Vv7EQXx=Oc*B!}o6a0GGpKTwm;jbX!qt zdrIxmrqI&~=#Q+~0yG~|*^hm}S<@zYYC-VNrAiDEFI{H2ySjVkSzBmm)p5(=oLA@^ z+7BL|vFzGLjT1^sLV-M@#;@8K@%KcaKcmWHiJ^@C6G5Vn(#@ zl)!c}!LRncMt|OIUV$KR%RsFL?3kRC5SH(d0ud5Jy;u=&IA$goh^1D>e%dj=Si(hk ze2`<5M8+!O7?Ikl_CUmI^UWf1bQJIR>Xkw(x6HG_9uOLg6xojix#`+&`6Q|V;5m3`(=3xD72}M%ChS|-_~g`G*b+zM9=>Lg z(mXTDVPd@IQ{%dykB3C({ryW3p?)zzUPjx*P@DAkuy!w|2Z3GFZ!wz=2yJVe=Ge@g zGwBC9Xe;K?sBR^7IPmnKdcA<~HIMt_;^pedPzAQ9*)VHU#+bkd8 zoI$3kV03RoBb8npMN2hap*QfDVCNn0^`#6$UDq;GoxYYPtHz+&Rt$ESDH>^L%1 zM>Z{QPpQd@pN}7p>rEQ(^OYaN{d9)5Y&&ip5T_Z#cU?4j_&f>)P|dsFnTFJRwYkTA zGeOn9!?!-1t=VG&+VRmw@3m+y7!Ru2C6!v#v`S)hKXsgw$7q>YBo(l`RUMWtZ()Q= z?(e5Xr=47MKyuK_xLs2$%u#T^nd{I3_X)tC zq5g)PK_J1uTuh-MT<`&snS{WLOj>X|~IKM?g;5WFxNn8Lgn;&e8 z576g|0)g4WU>kzpBpyJ(g9*%*;Q%B#v|x9_8}UjG4&a}|2F4-!%}Rn>f0BVyjXFWGOF0!S>z0fO^s!R6!tVSyB|lFtn$ zq(qP&;1>EDBd$VR;B^5TxZ?J2Rtj9oa6?uU@`EKAZ^%ViLV%@+4QzkshK(=$$%XM zi^21oRR$ORA}2~kz*M{lsVMNOj1Vv?V*{uD!^(ka_z)Utpi3JKP%CExQ}O?1@o#24 zSxyUP6}S<3=%N8)6>Q+)e^`9LtrQ0!s6hb+E2zK$f(R=`fUS}Z9B>ywYW`08W)JEW&?+b{${1XaIxPc zI^a>m17^MV2a5)Ls^JIE{uHqQ^|j=HX)O-qKN#Yl$$+k<0j&n6pK#(0ZuftN6M?)s zHgL4e&EPL}%mjRYdA%e1TY-A_Ukvfj|Hywa#6QQs`!yT^CbIvZz{Fpk0f~ncf338N z93l%9$bSIEKSP0D$ls)jz!ok4>^J|f*y5j)`VY4FS0GUZ;IL5=@}J|(Uq%@B5k_2y zlMNxqpPv8IBmXssO7murRx<_UKmE~PhK}06STYNlrYb7hPq`4{4WR^qp6UPO{vQpO BtlaoA1`tXGkY^BO5b= zpH_|r|9%4wc#VitYXB+<4eDB31Vexb+{PhFz(PZEH+SLX{ko6D%7w(uzLo{61RPbh zmR&0oLQ_2r0t7@73j{;}=%`BqoN^=q(%{hoTpOB|3h9(%R7F02dE}d_Iw!0M!?}tP z^u-Oe?zRg|N+YSDu17+Oh8V!5kuFJTjoG1C#v3ZM!Ze}5g^209!<(@zU5rqCOWXfd z!b3m=9hfv!m`XdNSAwGzrAUg|l}oQ*9tk z8uNB#GY-;Wnsl)b^mkLwo&cFb+Jswq0B;PQ*5*Xi$Ug4hV%F(DbLKNW2ldnEh`+D1 zGR21Z5_uann^E*I82hFw<{Ojn7l**O%n@aQ<4qe9Z`b&(@=wG`B^b6tZ zOc`p{mAn@&ti!#13gdQR-`+0#W!gA`BmD0~gqiLGRwmPbY{Owj1`Op@&<^>m0)FUn zI0oBg{k-9B@WJ3pP-;y2CFkTE21clPR)I?FE43z6EdO`bXbLn_94?p&AyEV|Y=OvZ zwI`KhZT{%t<>Y4eQYmKR)7cHwEQ8;=C?j%GBZUh)_rUdb+nuB3>1wclQz`jvoahH; zrr5L9-Sy1@mu8l`nx%`)?Dnx^2EgK12KqzW=1`k@vX7M7b^YwY?|G}skEl-SF{!&p zG+OyxGBq|dirGVIMe5MqB?2)j3L`1YE(UhoX$)&6$-X`X71hoDo`^Mb3DZafgYfK) zq2v0YaDny$neVb5Grp#3PJgRz`wOFgd+4siQ6KnH$7JhrW2;=_u*>6rs|E16V>N8Q zS@?Yj7;Tu(2Rb45b3nip%?{DPW%!@5Xu0>3Z2z2n%VkY4Z%Qa0nkVn$PDxjp1Qu3G zc8J`AR%0TS>Yni_bB!8C&iflowqL(MjeU}`JX$+CM$3XKpsP@?N3A5k=;)NebNx0= zFl4Y&FB>dNovpo@lP(I#-UsL%zTS}R0FH3eq0$Vcr1~dUv!MjIiqfQ6$;C}^(t?Yx z)`8rxlsrq6J-BnoJ3N*?N)YKkb#_si&xFfLOL)F#(gQ?TvXn(VuNKqD ztTvqZ9}Zt*$xo>NY>K$=ymF5HiatE3Wv+GU;|lNAD3vD74A+(1`lh~azm1+i1%xjP z##^vCyH-`nNG{fB%qvK#Tmqhfw@-G+?VZ}@`jq}f6ma{~t{F|(^HbzWqGjc}HV+wF zDO3cHgD~uIDb@w+p>;(?#8lP8erhyAgSd0(HB?tg8r-Z%%dZE zrD7!dYN1&#`?RHi=>I!06y?WnpD+Wc&H~bqy5kTw~p4l?4UhPV(6szh4$7@{&3o ziqxZ?>|Pxb9Uqdbc_{v)L04KK1^4rkPg-HO$*j=i7Y_ZNnBe-mt3fCFg}XD>W({V* zK&z-F1iozKfIHv1!hi}#U92BIl@W(CzKD`L-?XnzVe`xaEyONh`Y7muOAfvv(e#~s zaEXjqv}!SNkWOCh;4fKVvMx(-od|8d!+xeCd?@U~auYjt+6*mlhq|^W?N#qkfF~Tc zxd2TVy_SHdIw}wY>)SJ+vsmKX5y~T&Eajop&@su_e7%{4#3O>>r9L#UXlHfHVh@nn z*n}s_bNUzG+av|h?j^OT<-ktyC`}+Sx}np7os-bSD_%{P)bqzkomsL#{I~0NcCO-; zOBJnFHhHkJMTr4Du_$9%1R}w2>qKp|xSJk4Qgvt~`$Np{98< zgR_Xb6s40ijtnu^SYxzNkb3p> zVr+8~%w3K;aminUX=Vc_WDUUsojmpW77LN%42M^Ms1xF<)7=;X<0P8^+1hj=h$Y_H z$06Z$K~yE#+7uSj_5P9*q~FZGL@en}@9^MTkVl=PW|1q5#A%w zc!iZqu0>Ph2{vmmYB;We2-sqUGP`g{kv5u>UR|@UP;L=62Kd`)cxy@E{=Hfbsn7 zz$+3+K$g0!!!9R^plqix-Kb+tDH=tIXs7_wN-vm1s{n@nw_M5*WwCJWgb^y3w@p6w zLZSwAjtW9eIG$Js^A23+dkJmm3w`dR;J@;X&?P#MZUu$G#ep^jp_R_X$Cq#EM|6oP zgg9x#m2;TKFsJiTb%D-*XmZ4l=h%k>Fe`#&0NmFmZ9VNOh=1k_nmA%@g=wFBH@U66 zm1W##hA+#Hr*``lTD_INRV70i?2*4XSX*XLYk^9WVz3QoQ^!I)vBga91TM)!Jla`C zL1@t3?d~**kzOha!a;f|jQVa<#vH5{pVvFpU4FZL6C)6Sn+?knT`$p3R#4}PqlnyB z0W?-z3@Mow!KWF;(?k@AAv_&Jk0rS!aX_Kz7$@k>rxG*-5nLs)bTu4XBl@<|B)E)c zRnMHpQxijd7>nR}=NuZfg51f2nZ8wGr>gQP4IHB7U}fmV!!5(zZ(byAh%8tkRBM3U zX5~3aZ902rO?t1DFfc9C9567(QPd{gC`DgZl&u7OKIU{|7jU5ZPt^VG1G1V2cKR1GM}CRIN%1V z-rMLL^wcl8kmfSayn_*h<(DE#Zt{rj8-C-5@1L%v zF)4mtkX00-S_dvcxJn$klW3fTPs6%pe_4YzKURt`U<4hb^&Nm7X#iYiCn*ay&Wt>o zfGiKl00CuLcFCSjnY*D%>$aD|k`vuyu0W)*tf3vdka*1#5w-OJ|Cu4SN`}LLB^FK_ zm}|Iq_}{Jkl)kJTz1)>p*tON-db)J9yl1=ELd-}YS|~T~ub9}1^inq4Qm-kaechYX zSO%Xk`p1IyyS+Eg+7!~1S-Sd)y8w{?4XZfoK&+TASP^`6dcps|>OY;n=)b77>i60E zBYE3YnNmt27|C0=E)+7t-J7P(T39x*B804-B1s<%!fUF zAKRW`NuYL$)ef&2{I@o!8+ntzWKV^9`=3AdEzp1g)8HH3fCJo=qH?KF+^XW{<6yUl zw=_VKdRrU=&VqAks+kbefovOt#N`}s;^E7%77AF$CH|=Vpv*;^)Q27inx4L0(t2R& zx>eb=zYwWkaY%#L0cISAF)483ek%dRfcYSjXT`^qFXpM^KKj5=)<2s;Pa5M+@EILF z?$C7`Ss(j$*>k-vYbF_@%{d#;^-5ig-vGcYeP6qtxj8{fF#V}t-k>(KoQ`WR7ST3k z8v;Oz1YWpx-(*R_$73x{n~D{xs-Lh*|Yg5Zq)gZXrtFU3@9pSGI2pI=RAh|^*?1jk4o)N-&tGnC4J&vmv4jor0Wi(YW%FHrMeMcA=7tjvhPuXHoYz7nY25xYFpwc263ks>SXN)tr(0x$GCxj6uCH;C5;sRQx1vf)0XEJmAc*a-5S$)pbfycb;=HH z!)3^y=;qk)(B6iSMIf~2tjZQS?CmDP`*?XAg@Zt-1Or_@a@Zph0#p?K9Q51p@;a(nxH;Q?ZtdU|i`(GSY1009mSV7>%?!I9S=SfCVoI3LSuP(}pHG>ed_HmMcoCr8 z8S2&L*`Ofae21kSNJ%tj76TX;H@sz1m6MWA6 zLd=X!bohIC0%f4`gp}IFixFp}|B5to6)>dxXorB;zhR~I-34B+djwbe9eW4EfAz03 zl5{n?H47tqII7LhOauR_Lw=VAM}o4LP^nBcz0Al3ZpKsdMVk>($X!7C)GF`mag7xN zfvw}rk3#2es)Pw{7ixt2ED_)cq@=*3*hyeGpu=i-4?M1YwLO ztwfwB_J&2FZrGlSKqVz5fIa-z2OjkZC<%N(M{noMv6cM#_7w@9PP_GGy zD7;XmbLj4R<4%B%;JPpNEdT^)L`eWl;O7CxIzs|mDN$;tDIqygk-o%NrrJ8~(ihJ- z5dW`psb+-*o~UF0zuZfa#-`#PCyFl;+Gj6^X}up4iRW0aK(=;SQh9Qyy0^}re48!O z;KVW#wCHQ6$AHj|X$o9nr6Ky+B>NZI9#U)hzR*TkJH>9N{S2b+2G&rq1*HwUsEt_j zx8?lu9S4ZG(+n{#%VaY@g=hZ81{fbF`J*$Gqh;3*Z`55KBi76C>iW|;1Xz!=Rzq~H zE5rjY+7+v3(|oKoo`pRO2vg4=y^XHnL($>Vw(;3kl*(NfT@<{9f(h0gDs&NOp%}m} zp+35^UnG-=aAUEIN0AkfnqO6ycF}KHVoJX1>+530>XKGMd(OySJa3TT0wCSOCc2x> zC;xHn>#2e&vlRtuMD4{3IF5}x=FM9+V2S$|Q_S4PJG;WFNuc{~-QQ8j&e|=~+re&O zYs^zl2(hl$M0d?k9!=dGK;8K8>i@1(omn11Xv||FN;G?_A2fK&<1q$ovdjI&Ed?pt z3+)#Y0DYUnD|bifI}s^G1SG2DP3p6Z0ha6V;E2(E$?Lwgmank%Ivun~A<2$vgQjQ% zX{qYhuv=suJDf41`vw?Zx0hQ}QXYUrRF6P&-lf8Gv&C5>9e>+1!b8tzL>sAYsS>Kt zZdOaRCdgolEZ4gHl|6|Pg|`%+3AC1>rliJ9l>alhmSX$F{>NCD36KM%c)sgwd|eWsM8)Y+u8kU;=#*F-UCt z93wRI%oYm3b`S$2JB6+@wk?2~yQ$)qZ`OzH-Unw@2wD)tO)nwtT)!|OW z-z4T^EFpH#bK$d01IUx-(AQaw`%4L!CcaLaJFo6|$~Nyz=~x;36nB_i;4yy2?Fi!S zOv?KGOxr2vW{@w)5rt2TcQN^NdR<+@7(BW5{Yt?e*|Pgmdwy*UUmnvLiL`);`lv6u z0>t5dMPk-D0P*&X$Lz&FXE&n>@6TMxfbRNF74Zt=ualvnE<9@~gP>aB*Ek57Fj$hD`0O`xOSKZ4GJ|ej#&Um}CoW9GA zM)JBQg(<`hH!AMmV02M(aUqXf)#c@JKI7go6f#ZCS%LPkBA*m-1)H7^kUYf4udfrH zPT^cR90852R8fm3g|R*O#8rEV%QW5xC7mMy`Q6Yl)2DVHtbErOQ7V)+!$=Znh`(rX zFy4|+0jzkRVTin4kz(K?V6%LEo@4XYDABswC=t(Cm*B-CgX5gVfde~cj8czq?Q8|6 zm=s(!cpl#kzah;${DHJU<2th8hkF1q19_=H0zGHT?z%h$xM(Zd23DK%A^n;ex|JkVjiXKv$yh06F(;Bxm4NDH zy>Xx0H}m}xvNlYsAfh|>iu-Y5(8{2MLsSr$?>)R{V?`IhuI-2T94mG2Fb(v@%i{paz2FK4 z>aQ1uO!jjJg&xp6&}owWHJg)Gp-$<KtOip&CQ3J z5gO}30;y-r=+^7*j}&O;MRh8Xi{R?}(eDc*$o>^f6VN>dCbdg>9KkTS#)=W2E|zwKOpBcJd<2m1RwqO4to$#d$y`g|_X<~mSHaGy;yDU}=(Jt-a7a0`f^9QP+pQ|2z34p3u=n%*}jQ8k;z);X*#q+njYsU04vl7=$c#7?C2k?5#e(ewW=`Mfjv-^u5gR`CAb?flct0eK=Y@^Ke6 zv6WxNLoc=?nz`yb2>|`)Gsnxvy)i+IQ0R^M&Hl{`xGhxZPqldvI0Qblqd$loj|vT~ zOYoyJMjA-~SPga2=0kot+RxYZQtd0U6f*O|*=%h@eDD(8tN`GQRcdzV4ntl@2$EMNM-9}oO8`jWZh`&<;*sOAA@+yZ|J`GdzbYqTpFUUqYlz_Vbua?`RQ{

EUB0}3qBwE*P={=4g-ApNJ1{?&SbvU=J`|9rkJz60>_Re9iWKw?7*Aj=n3*YuG7 z-Ji15D`Nin<9Wfg-q`fx2($mv<_TvC_Kwyx9=e4Y_zfDED=VI8&j3Aqz%GGVh<4kmZlCAh? zPWhtcb??NJw~}{q1J+l1x^nr*a;I1WJ|jv8F`R4>DgI=VO}-PzEk*HYa#8`YNmsXf zt6QK_O-&peP)zEC(zdr;vw~dkH+!LXqWC${BDUwjxWw^tmPUuU)rKYlkks_8*N_9$ zOyLCwSADpKpYOnvoX4pRACmWo${7&;=(Xq471^LvXu@WXJaU%1096q!lY8s7s6!J- z@A-XxW1VYUfjgXDW8b*yAz$O_IKj2SE87Aaf$7ZS8cS4DxZ-YwqhcCQFOZjgx^_JNKn<@GY-9-roQns#q9Tj0FsyBR$>BT5(Sy*x2BekI-z-Pcq=W)B1#7DW@ zn(fKqlPdw9b-GzWB`hckHL7>ywincsCZ!*rbMs0X>x(Cg#V_q; zA9M|Q`!#0);08XvfJe0;J%6*BCea=KE!|z)@gI?&c3-LHaB3pYy!}ev*8b#dPj6Yl zGwY%(T?%NV)8_7vzUA5-*EP{-&@4%sUBhyZVsA+wi2fG*KB@7DV!DAc{ge?-43Luk zbbq{#o6X;D<*6bNQX+ugMBttb8-AGZD1l#-a-IA0P0wu;0O#x<7EgLO9DkB4!b?cS zvA4SP{aB#&flm52?!!29JWug6COK+|)roXIeg$>w4e=rxEsQLJs_h0VO0?4L zmjm&`gZhciS|s#Ku*(Dn>YZ(+G{rF2HU>2Qvmj^P$Ys<*XV=nhd<~j8%Ji~Q3C)jU zS!W1hnu5g)z>Xfv@hymKd>0nZ4cSiHDC(cX_PSy84tmxY&#e-%dj8D`o}4Uw`HBU( z@>zW3kuW9>WN(>f1v`#Gf74^`D7ByARKe^mu=hzYMMPmf`C&gR)l@9cT2iLgzx(mh z1>3)d^xS5~Gbr578?D}7oV7(8pi*~Ug{dE}PV5ifQ-vx}C*3)}mjOSa|2J=v_6S8# zzs$Y~90&;SS9tmFPW=xu{sWkzFKp~eA_$E7eS+r=U0vkM#1XhH?dA($(5wj54YhP@ z=G)mxvah5mbBb(z>N^WkEMJofLw;A`Cb)_B**iL+|C+my5Zv`Fsh@WrEA&(*S>~xZ zn%w2$S*(1J4h30D5o6*oD9^WS3-pB8L7kIiZH7(e1Ke+d-MS-?@=z7tYIJp{jTxak zE2w{QC~gEKUfoXd*0q;Tdn-SwHbm(9E?IkkG~dpwOu-AH`nf~vy+$EcV;LC%H|~!T zPyxD3$?!GLG!Ifwz6cc}j`b9ZF)0|dP&rQ&6hAPTA-YeUHno#&M|^pI7oVE}t)!qt09Y!;Rs^cZ><$o$s+`VlFq4RXUN=jlR{4w0+-iZ?Q_$Nf z0sw+f@UIt=n0SAa6>MRy+vTdCt;JizfHnBz@5Vu*tpcZPihI9dvt0y7x)}S+3K3^! ziC{)SoM_QG8?+qKg`PlOd`A*$MGfz?;~3;cy{BRM*9sx58_VK({qvX)nT` zG&^T>jV)fJucnD%OX1lWsk#+yS@SwOwq&?IUQrjG7=P9t=cUK_LoAI)J}5(=0MPMM z-MWPo`y4ZSCv63v#gRl`me{=Cfy%$JTkJTV^7KUbjsgQKBLHEu_>-8irY*2lR>dPH6 za7#fb1q?!xCbi48aEC}-$O(1?Y{Ttkv1Oz(_1ti&Ida^Q;C628U)BNznZmMc?P_}C zDa0<}LbyA`*d@`4RPF?Ru@v?;adV;2vh)jP*wz!77AznYV#y!T5wmCr-Y=#iB^RM{ zs63{(!Tnalq~*%TYbDRe3to$_7tbrDHc)*e1|2EIX}QLios2vR-hIoV%9@k6nM680 zR^6L%@QD_FYK`v@jVZ}dLX>gk{tVM*`T+ljBtX_s9H5gfCD11n7y7@J8fu;N$v{#6 zQ6t>?YNCW+&UpUokoYg@0`(6Kg~khH=7D&++Kb-jkQTXgGOf)iniR$!wq}L_Q2VOq1k^k(&~O?A%C$ zV7-~J!C0liy+lOB?hIQ2dF;_7*VxhEVQ}ICY>6W;W-s;t8gWC3nOTmcW#_JTcG}zF zTsaXcY*$?Rjp$#C9v)~ZFuy#ID;#QR3|T4RB;c*#bPc2Jt?&{~8PwiSR|(L6E8Yi< zdkct-T_uO>Zy0o&s21Zd3?M?>g4Xu*&Wsr}YXpC8>DUt`bCR8meJltZRe;jHiJKHy z@Uq(FPW?uas$xuFhUy7PIhfpy|2Xg|#oNWYMKuO7$Z~Xs7|#2{`U=J;e?KTuuz01H zrue^+O_OLX$N7b9ReTT-=6@l3D-;pHFih)!k>ut zGfx^ReX2lQ@=sBGyJ@>h-EWG@X^+b>YqQaaU6-{w*nZ}OZ+z^p7QQoMl|q^v3&NH2 z1T}3Cd=k~qjMmR7)ohD~e^R%o<6yMXCQI##k9IC*N;vA_@u?w6LJ)QQ?y@uOezHcQesEBnBQPAJ{p6&{8_C?da>Nk2wcT@s>Fl57KAli zZ>@v{{t|`ch^~Kq3SQxg;bws%PiHGp>PShTV*Q9?{kI=1UCL`p0w0HDRm!deSsYqPY41du`euP#$%% zX30j!h+N};9nPp$CmK+lf2#FJsibm8&KjUZckrM`=6KRu{CwGeffl1 z`5}|$+d~~Rs{MWfU8|MheqD#Po>n1_N{(&wMk0DNavyr+E1HmBbREL(*54DT>{>Eo z^-FUjA%k=fbS?T_HqHtGKA)ZmATqmlPF@~sM-7a00ihX~?3QTCh74|U28JIbkIhyX z!q()fL6TO?5vd77A@}|X9-_l!HTUqs!?l{GSfe-=!CA~!PH?J5dbGmJopl~+3My@4 z@@cV0)9K%438Fu`(WLeQvHWhxlfcGJl=JOILir2sej`#PB|S<3Brz@a2FR7D+Y}0c z(!n_o#aCThuSQp`5D!3I;Gpq{=&Chy4g{fbFL)>rl zc&o{742W%L4i^~!?BhY8Ba-X)j5y(ND^I^mJv-QizuI&H?zPu%u)eYa5jKm2kWE$1 z!E?T7Rj#!aQYJ_N$~|&k@H;1MbC=>xJ9qb#*uHmLBXW60R*14TSCFMu$P%h-#lD?j zMR6hUQixJH+h{Wpu@xY++_2c`)=2DD2*0W5JUk8!8#RIe`k>f4#M)TF@qEnM*b>|9 z+KlO3;nl-+feQ*%^5ei37T`4A7*W5p{q931y*m&9Wn7gr!m(hwtIqHM?O>CgOmS=#|vc+31<_2A`&=)M2gQY03L@Hs=Ogd2M zHVb@Wn*U6PWAjYOeK-7jom(dl%!_8lcHgw5-KR;Mpg8IN2Dp?1)C{u$Gm`>yRX7oL z7~#`3q3&&tipctVE1g6zRx3ag67Vmc|9gS$A9h>aJ=u$XVaAUD_-XYoCkb$Mu(P#t zvHTZm{v!|1)9n6Xj-L=;+$YNuSUZ-pqXFWxl1x(w6_2H8EE?|LsPY&Jsl*B&(eCxYo{rGDsDWEYw4jw?(_6APWXeq#{@~XoOv~Mua`7+DULPh)`h94t1$jMu^ z8)0Wpn~GY}7|bsqU6N_eoy+^=K@Lz{D#ZV-zUOQYsDq#EYvQYuAtz5_o7A(&y5{@)5)dC*Y*d|NlQ)M` zw-XIg-T&nwI}}ms4g7*x@7e7_iZTl;&{$ldGZ{O#-pW6rU|`T88roMn^Z+%~bNyy@~) zM~|BM3|d%&6;WzqC-E{vO)0Qx*vxd28Q^Z3nDJT#u9oQvy)KaDPZIbJbV=kba){o$03OytkIjY*!B_v7hU-sj?Y&5XCv*hOpsA)K`+ z@j*8WySDsrQoZOh5cR$BROreJ)6n4g9O;*vRU_;0z{C8?<)EXWL=j-kDoS9`LRl1<%vp)G5iRx^CwI3i?E&X1 zp7JF;ojj2DV;rPcn&xF<$HxTqdTSO6q`20Vhcv$BP>Y-9afErQ0s~DLf<J8G zR;2fcYmb(vv3(p7+IrtkjiZVZl8@Keqv?Cpn@K-Px8p5m$TiunLD;vpT2IurRu}l< z--aCxHMw4QFx`({QEW_;rFfMOk5uX78IU*Ft$LhA9_taS`W?7+_4PQyj*DIiL6=a@ zdZ#WJt-NjQ^Q5NpS;l%wf}2MBWAKY2`u6PPG(1x#A|mK^>~A6N$BjEd<90lnMM*4{v`*WdavaD<$l zr-Vd4|I?Y)uxk|oxi15uKtKS(ARw$DkRarCKx)HpfDAi_Rn9Nk=ydMnVl2TYgAuaW zvcw_x;@NhmyIKlhh}ptKiLZ*A&7hW1WN&?T>_!sExSuV#W&J4n^43Bdja%gjy4IcfvX)H8 z0P=e_PJ)>p+RAh@on^Vk>?*q%Sy;!+gG5K&a5}cp9R%H-KFmAi-j8{2?~jACcVZ>I zOkYnIcPF@K$BmbpZGj&w2JfZ;vhU=x8rS?Jw*>KJFV-E9-;7h^^717_sa3z}< z=9T_9S+ijTL(10+VG~Q9P2nTQ_46qfw(t9!bz`e8TOFsZ;oO{P=?OG5`eQ@!s1o5X z9SM>LT;8=W>a{1>85y-?^Gxx9uh~ljJZ*L5Hcp?SFS{uL1<(|eP4vY=# zr<{R;&|QeCC{n8!SuaJy^;vP{9)NpPnzv5QW>z12mtwh!?a(kcQkTGHv@m*+*>kJ; zOcvvGlLJyny8QbSXj%IDXkw}B+26;~q4ZPftkLOQkyaBoiXSS(mXzi<$VwM` z?8%e_Zc&419z6?FcjWH$5h=|5U4P;6Dpgts3+$haQLQ+xh2^QW-HQJr;Q@Y^Yj}kt z52WN8q77*N-d{?H$nT0AvH-;DJGQ4A6+8zG)?_FMz1TEnWR;F<1~RtaCH@9ib(@QI zqeJ>3K&aN)E+8b-encu{PRof3@pOZlz)-K|y<2IDmT(M_rCqJhbvy=x=V|R8)efx; zdRcFHfTXa)z0lkDviF;@HjUI^mo(KUt%#I!XP+LY+V~WHQ`sDho&q4zEs5|rtv6d- z<(V{R?9am6iZxxlBomN#|C3?7V*>2dE}9X=K~tv{Z*(=f2$b;oVFd4ruSWZAaRmRO z!lR=7;(62Ir^S8Ng73%uX=}EYg!gI%B6Fz1I{Oliz_?gv1=w)r@YbFVw0~l`54*D{~*r|;BqS5Fq6tc0Z7@p*uQc39$y0NOxaq!4wnEIGQX zCW_a9dpK9t#LIr{UP_K=Td?P=?R5iZtQuC=^IPU+SI3t!(OIG@(j@N;F(VKks_H`W<9)$Q#)vSaZxD;`23_ z%1>>rc*iGi%Sm{vzgK*ZbDv26>&qKajgT5aIrNw27NL@bmL9j4D8VYMl9{FDp}~Z` zWZ{AI7yR3fA6^-No_lvwY#_OE#k-69v8#rz!0=-SoVU-rYQAmOA%CP#0V?Z?!Va zh3>T;64*X;bJmaBt)q9IpIIe}0R_mScgk0{8kxizdvq<$pH=U;<7N3DLXY1+LI1Zk zA5Q=$YJ&s;8DabUk+H_ zxR}V-j-saHGTp*^{3&GoPB;qLI#PY#8$=yaLQE3Tb0Z!-$W3-rU(npGGbLf3IgRv@ zGb=xZ54f@Vj72up#?R%4~>1t4^fN)?msTXSmPejSsHW0_X*Imhna zmE5hHPO&lfp4W1nTif`7@7Da3UYVYOUm(S<+|JC{AIQo?4;TMgLqp+;wbhT3S>W#N zmu_~y+uwUSgQ?kWyWSq<88h7Yn!jknjqk{=8n|TJZWodN9WF4r3{jLOktfr0f-!`} z1$f=DsNC<%kS!azV!GjU;Ph&cU&R&xK0Z9b5Ri=AH$HuQ9`JR?7yT^!5f@=It~7^m zh)3@d?eljLgryi&kS30nNl-<=(Z~4$8d7tYyT-VJq!3LwIrw9rJ&lVor56nQqQ(hX z^oGXm@~RUzox{6PhZ7PQRQv1SCP++=0N~W%Vl)Rx7rPXP1N->aVNTlC*%*>*PPRXk zj@*er`SNhZGV+F=Ua?VEuAA3=DkUsr!(5eF1~P5c9uCAxDV4CB&jU$*75zc7MS(oJ zX}0V6BeSGUUS8#3?y9KzgyZ`#Or`aJfDqnZ^ zr+Yd@$nC9k0nxac`UqgkoQMF{?5~QChw}WKL`|wDJX|dZ?VD z7m9@DHnw|wqM@{@L^GMKCz=UTM!*pZ0ymSI=&~he@ZYI)IiTF~Z@21786_h7vUeF( zEe^*+#rqnOyHdU2Gl?EKHaLGBMGY6c^|FqRKPDHb?dnua$Wz9Ah_O58I)!A>lnpht z*sm__KUZ7Kxr#lWvk5pR!3Pdq;Vnl3K6$w7*_ONO5L93P4%4OfoHJK^paHlX4-hnUISrzy}mEI zD?gl;%+40n3g(+>STHt$e2O;JNv(0_KD^bCj;n(~Qm=t5`B@?|s#B^>Z119oTxm=P z;hJJd%qg2HuBS`dOkr|*VE}5UESpnGy5V&+cgVOXw|$nC>(a_~b>Y`49&K^g-G6J< zYtw9H2R0flB5`qiEI;WqS5%;k4oW2`^ROU_#hajKJ9&fnKOBt}RZVJ` zn5+kY5BvMnMRZ7OstJ(~F663umRxbEd!BP;`;X{!eEf`GJG|fgUQ#N%CIHnLx3T(; z{NMDi`f@B%IJVRcUrBf5S85{gFURt)-#i0bnXtb402$!xQq~VW*G>EE^(Vq$z6#yXBG>>D5NJMt0>hN zC7aN*r~^_n1JEyoStr@DFQxRPel(D4vDHtyPydOsxwtz0QhZSowJ_{?U3rwCv$-ezZe=SEV%s5+{SL#WkSTlGSpoL8(SAyL6@ z3q$S}UTwE%KY46C@QX9p5?w3`Z!n48$zWyzECBJZf#F3zFOpf9cYb9)m3RK&bSKe9 zi|_{RoJHrsDoUt-X?%_O13!gPCkyT4U^wgH4)|;vL-$CUwnszadvJyY3Y;R60H26k zf{JOez&keI&(I&D3AI-z*g}wL=<*C zr;Ns-w;A-}-bnNrK56m>|YIq6p) zN`(Db8QqmPcv9u~3TU;2FDumRm0laBckr1;s5V(iMniz(sOLRe5Peo}bVIRMQ5>mG z34n%|)wEtU(1I;x^bKJ6p&Yc#x;jitG-Nt9oQ8gk=cR*4BQfw`7RBwT!uZ(AIe zcT^|?5d_2V@vW=tMNFt)kBU|T7A>DuaB_p3)7P^yw$4gX0O6y5BM`AIDYdT*n?$Zl ze`uHGT{e#+gFz1g2))v2ni)3-+6!~XAqCOpy2B{SQF1ATQwoCGbuYhV5(88Q9`USI zVPaVtTLKo%n>~SJ)>>HfbuqSuzPkmf+&)w~5Xm5u!9x5tU)?T`jnO~tQF17f_hDeGOT$K zCX6wZ>O^=RdVF@3eY0`fV*tKvit_`zT(T>?h@ot;x-1KsK?G!gL_yZwiv99It;OAI zl_162?7ph!|0(0#qoLa3IIg`e-K#N-cioIpkw!O@_jr>>-bN8htF977AsJ(snaHcB zY>LuDC0vQ_rC3T{(}QWGB|TI`T5|K4VyP7OoMW!$tU2??e1E_5*^fW=nYGXSe!ngH z&Tm(O%&|T>8@`N&U*~6bXl6;@E17y5GCL&i$?GO(ce_G2b@SqJr+Uz!zvwkfqb~Z+ z^*rPJ_PW-7ua0h4f2Yo}Ym3gYD?Ao5_4QdR|2pBqUH+vgHM2iLH@ArPM)*7`Jmhvo z9OHC?)xlN?vjO(4qFxw7?i0BeK#( z{@vXXG2Hy1o7Jr&!9C3mD!_JF^wxFxwFeaX+I@=4du87$4h!>ICl_qKwNk*b&#oB` zDoH4dNY@;byW+h%L$j|#Pj#vD)P-crDuc(qz;{rYP3XCPz*-=mAEo`p)x1~z@)i2B zyMLZ^?ksw7wpyh6)%1rh>j5v%C_i4l-aDslh}6JsTGA<)xfSX6XjjS9#6t4@!@(`2 z7;CTTtqRe)ZI^>;j?{YepBLN<_ZTr!d-yD}n#6^P)!O;u|NU+CKR8(89KDEx$O_ zOk8~LBKPT#f55^0WjnGvme}5x?Y8y#wRD!F%wrAw-C0zijReS2H;ID%RIS28ClB8o zVZ0;Pc(YrXry^trbMLQ{+o`7Pq;#w+!TP1^RMV)|=UzjT3HR?IpJLT?cjgQp-|3H=;c#QYQ}lBoI}r zg+O-jF-MIeRb7n(^>m=f%?K^FhE*{H48~PA;^42k^Dxpgyd6UZ160H{Us43Au~cx> zKR#vZ%5 zhNS=>CQ!jA2eD}n#vCzO#xe$(>o9pNkp%Sc?gV+t2H09BN%0^6<^5}p+Cs!P#0lq)xJ$;Z4 z+5<4Dl0pN%n=qN4LI-bA$pZs{*gQs46<}5>6$paFragENES3vl^dTCE-7I0s!J$LO zVA&SLrH__~!7XV7ic}F9ZrQBgJ`bY{5`}Sf6*%}v7;MVWMN2H;c=TM)xZH9a{32o= zMi=ClG%~P=!dy1#dP-(Ew)_7Z@^ELe8U>#^iv}DdFYaEf7bGhVdn`~Gmp3QL%5=ug z!{{u`GswV_iMf(8bg_YOSuwb_|0IaP#n{7&4us40z`+)Y2)ueNw%?Te!N3P^kqs)Y zRXqo7C5yG18$>GBBFS$^MQ{p?%GAcDj{Ad4l9Qnx7K18SuhQ>BlJvT4F-(No;UxHP zCV?Wgt(N3vf^y~?IA>{6q_$ExxF#1_VVda9O5N8(76~CCb=kDO~~v-H0?uHv)nZA_#(ngp>#ZN(y%k zpyJlO&$;{j@15sa#LQan_j^0mw+0P#=|$sX=M1v8vj>Ab?c8iZ+Lrbpdna=%Fa+cb z0Xu^ot-w}nAWg7~yB!4V3IYS?03TVn+u6I>If8&|tzB6_P7siXwX2X2l$4tj$id0o z(GBEj3ndD?}192Y;JkW+y>0*0fxBRIXQx?o$R6T>|8+r0#|bf@b`DjT|sPa4rk2#WkDOT zBN$>1CF<^K=V&7YK!lPO60*0m5E61QzXdi0Fqodd3u1M$wsr-(xp_N-LFN!kTL30V z1o#{(B{7hQo5R^3zp!Ly4e~X#GK~2i|iw zce7;!F*rN9y4pd{aW%IF1JVJ`as~lvbA#Afx&fkd6=$UWWl_Ih{(~|>dw~xGb^%dS zgKpmjQ5l{w1opCXb#n!M|NQ?RKQ-tVFuy_r)B)wy$_@fLhXefO2vz+LJilCgak{Cw zqm?OOHW$}GoSfXwE;=XSW^QNy^Lpc72-uqglC*II8M->#+qs>c^@A9z@rBsW2wYg@ zFIS&g!(XKaAZGt=(oodj>HSfXu1@X{%X9Aj?mG6%L;$=01%V$3Z0`#GgNf1nW;;-c zxB@-~SdA0N6AZF6cLex@da${(GsMXmVh1>mz4tHVp~eb)W_fO7u3$?ykgp_2>Q6Qe zJ@rf;_V!>$8z92aN*aSiML`_E$q=xcJH!#>>-Vd&p_f2kzg{NwuP+k=8D3ia??6IV zgxU=>%+X5z#xC?@=nHy^B#2h(A5V}1(E?=tc*>ty{l2j8pFg&Cf`H9|*y05s1NlNv zW}x+A{9D0YI$i1yHgL|!g?!JV(}i1$p{MC(j>l|I>v5S28yK4e?KU z=g|}zOkJTY{7%o!(q2f&%>kM>T;2Xa>bv0WElnMuWI(j%Kra*iJ?ul5f`T}^cZ$EmhhF`QrvM2D2>fSGd9nOoF;*) z`#ZmgjrJEl{?-kkin4aMx4)=LK!!J+fHK6;(#a7>|Da!qoaGH5KSL=SgM@^j973-J zon;{>Yanl*l{O%tasfEEf)+I2--4W%Tz};4%vhiy+7wvwBB!vQ3;Ya?FO%P|K#ZZ8 z2RI*W#R{kbT2x(59>1;ex7h_ zABTQ?Ru_M-Z-s=epXEldo8@nypxn}c&7r1yQ5CofotMbpuR6o!3>b_X^nIum{Fw+) zqyqVvi-U`sl|xVn^ed5zE6YTv2t>xcZ1p$i2hP7LJt(?U`LP}P!&Q$Hx`Aw<6|e)eBm#b0f$hz`T|q!0?rG;}<>cuKa<(^j10o+# zc>~p}qmv`+SvoNXSYZ4!GHqLE@eW)FBuRG%psMu-vI#)sT>9+nfC8Y{&I?!|IRNhi z9%2sY)6LTfa_g+z{k2+ziXQs<;TdOg0WyLWQ2ByxfdRmVzZ=Nk2UBWx_H$E$R$1qc zMh$YbgE}jM1sndUyz<)#G?*$D6 zQ3&Mv-{z4YXaSvpfQ}ZZw(b5A4ODSd-+Rp8q5V+F59WTT%kMvefPy)bnyVWS3V*hs zu0Z=KCMI^tbT48nNCc`Dpc($@4`Lu|Ak6{2zLBE^V2T$k3H|BX%NJb`a&@<~1cQNL zgAov$pjFo8NdD8_e!3&*2YbJ^wBO}=`S&lZNkbz$G~l~C+d#~%&gw;A=m7!z+75_* zK==pD?mXyQ+j#*7c!mV($p5_1@8!jJ2!H>{xlS)z`0r}`W7GK8=I=jh_!kkJ*8rgJ z+C5VTG}`~m#V-^OXzpB8XY_#7XL#vf<9`<3FTuv$@f^_~@cg5PT#QeC&Pl9+1a)R6 z-+OK7cnGMm02etM!ki_n^YR5md#R}Vd#ry}rQe^U01Xg}&PDx8xdn1{w*Wd3plNmj zT;JT@6Piw;sSsLh0O)`T+mEpm(2@h=2WU%vUXyr$9qoYAfPngQP6kvzQ0qOv6wo3x z75`CA7ej@Aspa2D{$rI$V{LA4Zvm9IP=|sBf573s*HFJvf;tL~suUaO22fs{RV|i4 zT@PeWs3^{=00*!YbPNFk+|_1`1!U+VK8O#PSP{;WW8wEsffx_y1u6s`M@;KKV0vO{D@~jt9 zKN~tit@2#-fNh@5jIBTx-awt`=nm-qVy^3a7GD8Xodvlcjt6aY?17mR+uyqy6zyM- zY6Eo6rp3TW83fcuKoJ4eJh0k@djO3Vv}6FNn|~h)LyPR6vt%fMA5y&VwX+ejGr%a| zeiyT4pd9-S^`8Nrha6f!lz%j8C=dVWCeRb0ud}Ag3S{`*MZPx--%*^w`PE?mc0nk; z|H9(`Z}JLsv7exIE+RLr^?BU=1@S)uhSK@}A$~)b`Ev~a`%nIS{$D1vfTGUZg#Svc zzlq}4HGcgMdWYtR!2<>g1k<0RMN)NTc!Vo3Ffb@EQHVhXz#lMh&>z6-8gP8iKW`j5agek@=fY3{Ba4Y)gzMi@Mqk6N4>n=LHd2y(C9?0sa=9HrO59JM<{CL zl11$Hg-RQ4OEu6rj6FF`Fmrw;6WKdCk;HiLP*Cys3tPjTTC^Cxhm7GO<`3uEd64PS zD^_~C$gh$<;l0g-Vem91a?>g>|8sTi|z%3?2B##6?lu%2Z zqu^CZwV;3SIYq^WG-5!BftT6Hgn6n;DJTdm7@BCyiR)i?la5cJf|18l*Lne5JkI<; zreIrO?ukT^(d|GEwn8oQrjd*o!yE6cVZ4b&+3@RVd??;}@~*acbdJAz9QMs$fj(OVUG;&1;9~5fVJVZM>j;b&k1suSzp9;2GIr<8Hes*kV^Ut*A{P zEjb|6fRbV6xx&52?hQ4Q{2D=a_H()~kdBl~ABc_{l#|t(ki9c8HTK`9=^En~|v zvWAa3`Y^vRwlsiP#MpZK7zWHrkvTh!g+#P@Qom2upLmk^rQRQF>2Al-i_}>&7t$)^ zV;$xD^3mn5-M^-lX{@-`;dV_|(FPYY8GZ5TeA>NA$z!wb`Etz_Mf`(ofmLUG0s2?g z4D#3pL8KS7If$=8CA@^3rnc%~E+IaTD{l$7vUt`i7@5nm7kilBz9PHZggHI_d?xGg zChF(ro35?V^9uFo&4v(@5QjX&+%IeSNOrfUA_p{Re6NbgjSygLcGU%$SiJkNfHcfE zn3(VRVAbjqZwp4l49~6dowv5Dy7Gp`sPrHFyJE16MZlV`lG}N7M&Cu%->>*ukWM;8 zra_13C7nDLc%MNCLmLY@kbfxh1Gp``?d$IVr!wzef zvx#5@B*uI)Y;h5IZf3%fD-AwyYz3N@E33pM)d}T~4)2tKTh$ofdX})I*iIK~2xt1% zt=}>|**k=kA37G`xH+d$3vU~g7_c~P=1fbt{l0EB z@N<(PLpbj-W$Fus=@$j8S(p*V8Si+|)H68-Jq>o=Hn#bJTH7P%*U1N_9* z^QbStaHXBaFIZ=!>`KxU2ejKvXrk&gN|i_p=UV0O?+0*Hi1HhL6s&*xs_UqlQ$br; z{_Y^^tf=$VZ+5=l#>eKW1R-7cjXLe4as9zr{XO4(|22NtUAcOk}Iu8PoU|{N*VPH7^W8egP zutTdNP75v$D=QuWOHPi9SZNBxN}K?XJGYTld50YWDU?+wwPmjc@gbts=qDifx^M>) zGNxA07Skq=Vs1}+=2`Vs(bBsIvXU)|Oi*oJjq}_Sp6Tf5fYlU16FuNviuBQ9d5Fz? zJFtf#@yHi>;7X<%JNwYg(o~|XqC$%{B7H_W=MF#U--~5DI;(T377@Yg6H^Vy1 zRLdh+n)JyV?okxxdA*Xw{yup+*H$B{m`iTHK+<_E3m>yzuat*D%s-63;p=T*~o!M$j2y`-Luw&HwN$N?X5@L#gSQ{#ro#t zr_8K;OpC58;Ws`%n;g^TBO9`*lT+O|Y15cr#VO=`h46H=L`xeXL~?+vLc1*>4w>== zTmFY5Qpwi@!n`jcW8{d)$38N7KALB}FFr`EdfF1G*5KRm`oWzL1l%=ODcqQW`(?fi zX3qG`BiZ_q0_L!}2%m`sX_jp{e0VE*Z`5wYnl{SQ?4Im)$vXtU+D_?38_}c2`ZOxI zY^iAMfM9T>P#j%AEPsW9(%(iAG~H#B#rS?veP=a56Gs;5?Yu;4=i+TM?2Y$cvW=BY zT1d@zE!^9;?-xGp>+0`#6rG6nL^~%UE?HdOQzxhs5_C-@n{$oG24~!Tq0hecu>3mte!zhD~V9Uwyr@O>aR%Wcm3GgL>NQ_B<}rEMW;*sG;20@f$VV0`6gL zk4SdCpZ10O%lbK(Eo9%wd9j6~U63uM+W;3IB5gPJuw$I+on+JmZRkW@e>=y4mGj8$ z)@ObjF#AEg-(FWz(#sFC_=7N?)@a6xE%HfXr{hC}vvNLXeaXk6$Js+zvN%i);_oV- zzTq82@cCU9hSVc;s{;{C#bYC?J4A^Dj0kUJ@783|=q5ecn&>i|cIoAZH1KSPZR+QSpBoJO9UxW;T@wOmF5 zHi*5jaPNl5llP-)1XeFkGLn5E(hnKYcO~h-Vf1yvxW1?XOW#wqkf{mKI zYEzH%&h%5tqV^qK1BxbD>5cU{Y3)M+*j&yMvEOH+jq?NMcDYz+M z;$-)HZoYaL^XVGlNlt6gfk zxVLx}o<}SDX=eeLwK(?KBOhU|jS!^`9gn*CfVSyiYy!X6z1rUt9+XcW*High*bcbX ztChW4x2co8o*rn1!T!<9Is?zUAC|H6PO^6v)isT!>4+-gshTQ{(l^8Of_Ee2@={P+ zW?~3b6g=nX#B(2L>xhd!+o|kbRlTZb}CflH0 z5^We(j0ffBt>HJ{^eQAvSSS0gp;vOun$Q8Bx%a@XqS5CF*ElV`RXQNUBrVfl$QQ==fDI8*9u`;`7# zoSihb*j?wn+mu13Jj!oA)iB$d7e$Usx1(@{f;X|UVyQljyksDhP2%8SGV&3C5&6Q! zw4$$V{P|Ok2alc77%T1kBUwG7k7OBH^;e;zXw{CB_(WY-}IJDs4Z^f77=S zU|B1CLS)_aRqN44Y=CX8?{QbPabfDlCyptKQ|@ZxBh(>}bb6sF3is-1$J(g@kEXYd z{8Jm&P1E*usT&@Ddh;aHx+wtuXHIj52{JJ2wm>9+hk+R%0)R0lN0!Q zm91t@wlptJXDDVjo?#6SBfU=s4H^x;EZZYDo#$GJod$V%wJlNx@r1~jdI(R)4zTPR zTZ87{@j1v7Y4{MPv5FGponN?%C~~@-IPbGzd7Dw%xMp+sH`yxiAP=wW7=>Bt$EF93 zI6pBKOqn}zpq$IqRt;dZLL$-}`b^~xV}!T=Qj^ojnaswv0m6F+1PebEC~S1l?f{X# zf~D_;BEAEWFP<3*^&eS%^^WsKw?8&ZkHh1WIZ;}4i&R_XvHIdb$9Ebd6$UDfJqwDE>M)Da?LfPAu z=wYw35SX>zxw8g4Bb}+)HJ_6-m|R_RebvP?CFAM4oIy@}|ME0qIJB#o@HX4sa4o#e zALt&#m6fZEnao@bldyh5fj5ds8(KEX)Sp8`Q7PRfAWo*%Cc*KFZKwwy^O+Ru>e7`U z6b*_@la)q~L!Bd7Nr}_36patK2$tWvdbvyaxLLfF%GNPAw1-rwXy3y3MZ1rL$a8KA z*igO-pLjoE@icQ+_>LZ;AycjPJ6-~+eK!~Xvg>Z(EMwjGAH=~Mgo7C+E*>4C;`8en zuWG^eFDBY-?5{MdVbCe#D^rk-iP{fpeo1${8NsS%WBcm!_I*84dmdYoBWseT4pmFC zxLYHSKz5_?ZB&+I)G?UjhpZ%TRo1j4=pN-Q+NdYo@0H@0GvVK-n&*Mx`u zJ~|}YA*IXIXeMZvxO-NDd|!xmyP_naRHhd1t&)`_b>U>)mj0HL+O=Go{P586tb{%S z;x-JrZnsy#%c2V{AtG`O8drN(5U@IAI+j;BBPSR4gke?d90YgDqt%C%&;%|H4z z$D*NIJB3mycRcd5Sk!0L#d@8E)9fDitsM?uj-fU3<=SZ?9wx-IB>!?1CQ@gArPYZPJFeVm>!)y zi63&}D_=IB#eni@>vXrESv}FOAR)6=UE(#hy;tiB*ct}r4u)>0)^NZ-BaJE8G zQQ)pJ(0_D>;dz9S(QibOsa1v@#1HOA*GgkWw6mv^Ls}psj`7K6P|RscJtwn`(`}`HWP5&r_h-X(| z$k3!-*ViFe$eiL>r%9~BMLI`TkvH! z1SUW?(P3ctVUYfFwEk&5rsskC!iWGGup7FDx28C*_+u}MlaEMb=Z1QGG!GN8f1=-2 zmBbguDT06Hh!!`Qy>f|9a=&epp>{!esv_otIgaQ=%5M7RyIm65mwsmGA;dQr<8bqs zX|Lgxv56Vo{^-$|e&^tU%uCsJ`D^VQyB@7sjTBifiCGBI4~&A0v%kD!gkih)2~XP< ze^md?&;Uf!C#-d@kL$$%lfYgsM+#|*ybZC95D%u06{iii{usx=pJDhWpBv!jW9F4ekqq35DnLl`qKP_HuvsV6R{x zEz!wv(<(Xa%C}uuel0fliThcR6`*W5bxKrh!rlIa_}n`fT>Cn*{;Ju9xVuq#LpIrU zj|)w#??x4CE}3bB1lCPc&%TmKFH=Jnee>eEw0f8!JtKTg6n58x-fZzP?iKu)*F3nP z!8ujmjNfK*4;4xC8juj?bt^?Z7?QLLxWl}1>vc)`cG+WdQZKF#uWIa_o=V*fjL6fu zhoMfp&+bNG zb-hTkR_N`Mq$iD8UfEw+ox@Zb-x)76gIFM52cpf$Cy^R;-SoLW?QHmoVV z#9Qa9de*Z;aKqFA=Fb}AxH`~ajdG^Y2pBjfVZgxf{wJ%20FzcLV56Ti`;Wga*=+s| zWv2x`9I+d17ECXktBUYw3#IOgvQ2iu$u@~zi6tGz13$@DU{wU;Bb;oeQ$4;9u460? zX1&KfdwYkr<*+jb(btU7px`>|o|z6!Rxu*Kx^n$k@xA;p_oJ2Z2P_&H%EKZ{RqAxB z91CMS{OJ{{32hafkv9?%yGXI>YJS=;w3hGpTf&Su!aQMQ3YW5?!zB>wW z@A(jl?~67L)pk86F@%&-@gau2OL;nIrtA;XibpZ=rb=_JZb!uA=BEemP2w=T3%BrJ zYo$u3gl>>GGxgz|SiazRUXXhwT2Or8BumOU8&vC??GdjO8e1D=4yXC-?qcH7lvT}r z16}leXK60)#o-%R8LMp*f*5V@5sysubr~2r593wp)a)!CCLJTzwj}0?zMt3MB^G?Q zRA}8lnPw0Z6c#j2{v4${qL=3 zN>g8DVrnaO#fvjEY>rK3+cDPcQy|l;r&Z6xBr{h>BrC3F#0Q(!Fx5Ydi@^|e!?7bB zx|#9u0M7%lG?Lz0fSY;r=}%mm^en|ALXL#?9A#%Ba9S^W?cF#M#bD&2)~& zknl0B+iCUHhgiZ$xmP?#o)+t@!1hcwRO%B?*00VpIt0BMSXo#TXigk+=wJ!k84z42 zZZ4$r$+Qg=5roq`PE*r=jqi0Tw&j7uw%sZM9UZ$_Nfs@5UcfkdEE` zSoZD{Z=N}g$!S7as++OD{%KOFxXt?Pyq$^h!LzHg-&8E33h!B$OY5m}ehasHqcbZZ zd?H?eY#d4YWm7{d%@S_4N&zD1(Tbt0ss)KWDdBqedjbbMq{d}jO^cY@)SCHw z(fvb+=T}yP_3g$)4s&4}7Hyt-cy&K0(j&Oi+3!u)H6=V@t^d5_1FO8LR((?&LqJ>7 z=}t*AneP>$69PO7&%xRETwLVa-=10-bqM3*Uo%;;2nl^pB;i*blRWH6zcYo+MK${w zeSGDMm_Lz9z``?K>I&R2@?+$*fF0ba>iNU8dr<@(1}xiEZEbXg6&kx`piouPNKZQk zjD0EhoFp=IDRbod9EeL^&d0kdC_|Wu7IJ+o*^`;Vu10+BbHWOX@q|I#5z;FTNn-QI zsI7;OcR1jMO7FSwM}IRD0KLw{#HT3a-%LbzJlOq2@$FL3+B9L(FYU776$kFIK!8K# zUj!{v=D^T%lv%kB{QRLg-*C`k!}&pNSF{>vP8dv zd^VZ_3G?XM7K9N5Ba1p`Xoc5ln3=yG-65n@I~Z%$8D51NDI47;m>H>EbFJJ|AFl85|| z{n$r+@K9QKZI8c>rLpDfNTbNs3=*qoD_trdhq!FKaLq-M&(BbJs>o%_ioIGYSV&q9 z;&hXWJ?++XnBtB0>U{YP)wTwf}5|R^^L5TUV zhHw-^Z?5~Q&jVE1Rn>B8Y-?#4ZIJ3ti2`9amP}u(f<0XfaJI3%P@`Y`Mm@_o zl+KjRW*<#9@@ej2Y2%}mw>)7vY?Y=dddYg@ikT7SyqeF6BUq(&Cn=?-> zluv`qp`o)Wm@s?YZFG>j|FfAf6K7P%(5`;;bzm%Ti;zf^3YuPxHLvLjwW<%(8BgJVytIl?C!VV6 z828!j#t6&2iiD6vm~g}<^3Ng!0dSC{BjM;&z?VM*ha7PH_hmH+yAxGbay+y?D9wDm`v=OxLOHS~3D&5`Rb0PY3HVLm}XO$J3 zr&(y21$kX`V%u;YA>0%BAemxY6fcqjJD5A4i*dzlchKuhqv1whhq32V?oLEjbnR76 zVt23p%6?5;lUOFe_E+Fg`#)pLj1fZz@%BX zv-;_vGh{~^|7J+Iw_@66I~qZ^*9@N0p;U4rY6&?i9%GK*xThCMj|gb$!$T|+x z25mQd9J-&MuAi93C&TQt9=-Dv|5X-C2d(pbfDE8!@IS;#3t&?Tbno%cSovhQv_?ls zMM-ylzIa%tLPuSR6}GbDWnS7d44fvoXMN8H5UXOM179B7#}_4VD%5j5C4LTjDSklh zRBdwuEC2x01djh9e*6ONhngg`-N2@2oAgZ`%ptc-!4A%Dz^vmeO#(60 zx6N1l(!x*?3FN~|r~->>0f)}NPtAW_7`n~c6uQIVQjW&#>%hDN!ay8u(mI|a$I`M7 z>@mP=hp+Z_roA!j>9_f<#05*zfd!NPDLfAj-IFFCx$DHT!ikUCW$P_RPc@#u4M`x| zNMx&S7$&sP6Z_Q+Yo}PtHO^Rofie02ij7OEht?dJeFIQ_kcOL3g>QEVk{3*D<5$wE zW54{+kzgb_`=w>CI?OKUjlPiT8uD`-T7t10RMt)iNq9b*b_jCGw>Xu49pcBY**+J$ zH-_?EZ8p5b5+a}(lCMVNrvOVFz*=(u-Xs7efT7!UFV`V436+k)KpoZ0t?>QqA_0KC|j@#|3Yr^zOw{=)44X#8z=0omOb$l#>Cg2SNBdi1=Mmn zccu|#-0pmEYM}MoG()xi_z{j(6~XI+_s($rM{4_5-*Q_ByD@4Ei9kKZlt!Ho^M~GV z$W3(}-syd|uwsV4>5kq@_PSJ)H=il?p$}@?12k{NR@k4W1C?{0#3U60;2a`=oYnrl z>HI~`f3cMx5~rPcpNC-#$CZalg(qED?0es%Y2un5msm(#U|l(pSHUN+J&1}-wx+uFjP&hv+@ib4_~M7)Yb!2DYnbq! zq%4Xx5)SLU@Ir{X?DZ4TZli*Ol9 z<_V?noSMK2rH~?4%Bjtca3J?2i*7lxS{~uVs9HKbwNm!n4XsW`X?{pA5c@uaXvEpg zI`%$<$1d@j|89xs9f4*M@s0(hh%BBDTK8_fmRV>PdT`sl#w&M+AHq`Q#6fXO)_AO8 z@&njieav6$Q*!@UtR)LiRxcLOyg^=Ns;$|xCg%JI-a+;>-U=-xFcl$ZO8X}mxk_C4 z>y)xcof-14tcUHbTxOB(6~1ltb)%0=Zq2T{G4sU0k$dIfZG4huhuZN=sZYW0MrN+z z(fi7^k~-MdsB@JBO}Sd9W5r$f9SPnKc3(WzSi&4L575sx{VC`gBUXKjapYUVC@?Sq zz}`2Re_upj2%76c(r2~vQ#}W#DFM8bGE>fYqOH~mgDHp!`8&$tTVzJqzSG^;qFPL> z>T6`C-YMiLYq~Vco*s!xD|sXm-bMVBNEjgl3FF4j^v?EaIo(tnU4Nx)tW)KoF`E0N z^h#aLcucm^7~)3KRQ!~}BuW!iQ+Z0G%8C!oUd@{tuEyA9U3I*zIG_}#OiW)Ynj7e?}2K!0EVkhapJmFwml$ zw}7(co&~pA2qO_MLG%NQK+2ZnH+?zW5B3VCM1_`IJBC-M8u>d9M0+P&{YzjG}2g=O+8FA zjac0Z6gbMX)FVOhqe3fjY^BM%#W?R1X+Iueb`I|jV@_w~sz zoza;>@V7Js)EEL}ghMUA4Hq2~QY%Mb(gmU_JK#pDm0ITX39)nPb7XJ#R9s<*?c2LL zdrv~3?R1xt_Vpd_-m2QC7<{V~_}Y!>Ng2^`OR1!WdX#&E9G=?GnIffowN{@CE@8qi zJXp?pCvQN7MsaV`;Kt`WO1LxrNCv9oU9)+Q^CMQZYQ~B^Ocp8Idc!%6ADYd3V;%RC zkf*4Lwj27)>XQ2lSMFKeQcEf^wPm+uEa^wq=FQjYis$N7c$~(QL(VZcyk{mUd~XwqeYs`Xg>l>G#ijI`AD1 zgQnH#ss*f)UVf9FDj|t68LB#zPe)fxe%REgGN0?=xGI>@^WQM zqM_h`KJAo%)VEHjlW}4@bGWE2N&MNf0n+^4j{Ynf`k!64BhZCL@CtI{Uv?SbtrD0E00O@9~65YdGBvEun!VlP4AZEb2VQ(D|x{$<4rbH%8Lz2Zm) zn|zOaLkkQblv$ZibyTM*ZqaUW^d4A)jF?}nEew4ga$^K)6*e@Ww z=^`^}TVes9*3^NR|MJ(v}!S89G`1^>Aoq* zFZ^mt`Ev&8NEp#75pds$Wsg(OO1yTld!DZRNeLs8zQ^wtVuq{bV*K@2kjGEqW(~1> zqF&jK9ynJi6jpazaeXo(VZRpT#%Y|k|9tIfgx6bvc-bqS{b3$+`hzD`qn(}~*=@Vy zjPOdT-rXxxS1jr#@GEiI<=ubibh6%XtLy2qbH;29Nwq9WdMnC+D+y1Iu3sE}ryPS@ zJLc2-y$_LQ(iR!E?qDx0!dO3wE?l^W)%Tu(BnG=Gy+3y`;@FXERi<})7sT%^nnu2u zg3=@1{~)WFh0U*rCMLT`SJi_bT+uQEq9J9%M0u3yMs=x!o%d z2e+L_KQrAF8~Dl@lDhd?FhOgm1{(A_%&Z-!C;xBhWRqw z6@Nv?CU;yl-!`<^&71^N$TWNEG1L)f%4VwhsDRs1r)#Omb~$dDBO`qvEcf2~#g9I2 z9to;!a=8IlW9K^FF}%dAWRS5wTte)7d0Mlc(Yrv@6W$Uh>5tMX)tr8JMv zIXlI|hJYIBc!R%wbQdK7*@y7CasDE+_Y*DZS{Ywl8E#Wlt1mZNH)fr{&zI{{UF>g= zPefOk-HY9taaI-~QCHf*8Y7FWBzUyu#V$B{VCOL0-D`e*Z5%=J(L&GzEL)+hd)^N+ z#L{CCZ|QB9i}X;hg{BgntWO~`xa6*GuG)Xf2In#l(CJp_Y2~T#G^T-PKww~rXIN**)Gql^6lLual*^?33cWmDxY3oow zoa|jf)HP2J|K@Mq0Yod!D&%jckjiaV5Bltdl!r3dPOG*Iv-?%uAY!7zf@(H)N$Ysv zb!6+tiC&F8++f_7uS5hsB%Y$-d-d3QmVr`m>1QUA?UK5zWu_flbE6x&uiQZz4vSrcj4 zt?$|ehb0+g9nX}eOy)c1Zh^sspQVcsIzaHPb}1b#UkXE}P~efUWDN^x-{R+n=HK5u zCe(WQk_~xsSTNHv@4auW)v_Ro0+Jmy9mn&4pLH3OXSB+jV~GI2qrh<;IR51j?H8VZ zbRDcOMbUsN7;#Q?P8fv?30?U_QN-(`po#&x0g9rc=a`cs={}?2&Hmq!4{NJG|>XA`R3HtmR0jN9ALF&5@X#2GC&yK+S7Dyfu<8^M;C;1`F;Md4Qq$#t$)Z1x zzw9pzFs%z5691lgTXTrj+3Zkj4w$}Z-hs>Cj(&#cONVHPnE(7(Gc@T~eKg5S`S|xidqeSCMnr=oA-B?^YMx@oQvc|pFR1DH% z7&|M;G)>Y)Il+9G0oWsz$={N8cmxdl&{hqtq#m>02vo~@8~db;rqIe$WY8r3@k=<4 zR-bkb-$we+%z{}RK_m<5=_RpyCP-Wm?VNN2-6pI^u0lSzGaGC5%<4%A z(c5TyQE4PH;AHHKCzc@SE?rs3Yhl&2to(G>lTj?6JYn+qYl;%jw*u1r{&u^orx^XK zCM4tm`HDX3%e{@dGw4cQ5UKm4D`AqkVS+G+#Z>!Dt2X}Q8+unC;0cF4_o8nw>CnJ{ z;NvS=x_mI1bx{zvy4u0bOMs^$RD(g|y-1D3Eq)sA*KSovD1FMR+m5AL6M>SbCRtVO z9K+};5W#~HQ8D@Too6Ik!jM_1p3e*yWt>E`XL+ZlIOfNjwzo7^GuMV+o9Aqtu9;?{B~9Qs4K6!XB9A^4xE5o>DEPx!*dpBOLUCPbiIZ zQbEu$$-!pU-ppYm>KNt95>l=%~DCp>^(61Py`<-W$wtKqE9u7jrWK) zBUJ-`rdPJ{| z8_P2VbT6ylMf)Kpep=l*{EGf6YxUCyxleR+#zK(B=o7eK!&jP7GeQ^ODA|CcX#D%O z@;68M5yCF!tM1yBj==t`Y52vfWutSlE(x{Dfk<*;7>JryMZ#Aepf*3OH2jQEkq&`0mA$Y$Rj54X5V>yVnHldjxnVyb4~mMl1bl6_Ybpvwel-vHwRa zby`a^rPMSmNfIU-@;DQ~{PUQEZffo9fhaN|X^;#g8)bdCRz$q?*L^xY>REA%e$^|*bRB~@aMrQ2cRx2#c zTCKMnn2n9|PAv&m)6z5+6J#W*k)?V}(M@1``Wda2V+OPWDtDXeh_B))j0!Zh7QhXN zKOybl;`lVZDJeM39K1fnqlk_AO;4xaR}wupdYEaf(fUJ?MeJPLW7H0%!-oM+JW66q zq9~-3TJITgEVC3eC@YNU88sI2D~))*l|NxoM-5TDn-Y;1u99a@xO%m(j(B_2;-u{v z(r$JXUxIXGpP~n0HZHexyaIQE!V~+U(!vrPUd%Ul!GrCDa zRylg*&k!O!EnLvXJamQ(Ysg}Rx?fNBcz=BM2s0J=+o)ZxE_+EGZX3?Q0V>%-c0Nh! zc5=#y0eCJ{NuHdF!&Z`B`?Tij2T0zmlc(spXBG!BI=Z`(&Df z`gQqNtu^At@ofE$yX`H~dx^Va$L_AY?iNeNC>qioIG9NHz&F$q^3_IaShsf?AUBqL z#m9nojahl|P_i@knKaK$i}V!4B=!~@lY2Xk91?nOMz>A_CUai7RfruAL@)M%>>sLL zeH|P4{z-z>y2L#9$a(?hsNqB=_dGKfhBLhi$=yfwTz8gX%MSL8?udGMFiEVHOFO1w zcdvKtioDCGXXi9pSw61f<8!bMBj^4~SJRjsH?^)N6I{T4<3?4&+`bSO+~w2<&HH?$ zBqmuv%2NRbUsC@*!vGI^|EzQXQtq)$(2OtZ84%i@%Q>;l-Ibqdp_EFMl&2i#@9%(E z#WM!EDv!cCg;k#7U;~GZnZ?0_$H274MipUgg{LLNG%7!IWcl%p3GonBK|(>s$A`_q zPNLy^9C!x(vS?wVQM&Z>;Pz+aQszXE>y=5`)0LFwC)o%`QN>x&3yy&#)|7)nbjFCc zeA*n9#Al~Ul1%QGx=Y+2-}N~~X}P_C{%iDz!3unw4+y~uK(74nqsJv7{1!JZpZS!1;Lmb~Ufk#emDMm}Q9SNTv_at?L9>zTeS6PT&51+BA5lbe9 z#CB6&gw}wY{So&2Ix`dzDjSPu54{*~QBRz(H_0vAbx3{=^VmQlW#_=kklMz2?v1rA5|aTI zc~Hqd5$95j;o*Zqq~H-PrZT<cH$2|n-VtKo zNz6uG53+bfL>J|I; zzU(KMsu(t(6bJqA$6tKSrQgdLyElEB_!@a2ccM{4`&=VU{niz9oW#RBIVSB1-H&f7 zSekg2yM(BTMAJ+J+;x=?+v{Og{0Q-Se}APUlP9)RmQ;adWcsEM6~0;XrEUfZh-y~~ zwaP$%HBke{^?!dC#R2*~GN#aHA%L&B1HKU9`wd~B(16t%R9sL3?g?wo&ugl(!9f!3 zlM^M=(s)9j?LK=c!gk5bp@2yD8yM*UFm%8H?K1wgng0pUk6`mFrhdhRC8a7I;GQ+K z8yQs8QczKQ`SKSJM1wh1pcHl41GaC%0Nd7qJA41(Ig!8LKH=zO>In8ce{SUL?#Efb z%dE)CR;i=Js;GO}@u3p=+`dAI11yOJ9E$%w@wnPSZ@8GcyIBidzNg5{s#sm2(^&DP zGbPGF>GGB;=-QNxTy?m>y4b*>`R~o+_qBg$;$k1zFDQQ5*#(6WHDUbb5dfhVIR1y& zcmCy>-_tK^EGK#=$CZ%1lSmp0A^qZ1X%|iPXWfb@3gOsf_S+TSlHc~O<-d0EeAg@c z&EyB^jK zXi?9Kiw6Z>%xK{_-??`!NE|j7J?TY$PH+0X5|dr#u8yPW=mSEcxA!m(ux+FB)TOU2 z^x(0q7av~Q@D63ZNL^$-9bkMAI8^@!9h`l0=nv+9Zl{9!=(#L#LieOjyZ$1KqPv)U zg7$1hr!yfQLalpVSBb3Fk~F}$RtCAjLT|8;B1!`IhSz#r}&b3lVGU)1bmtrn5AX1XGz-K7{T5_Pgkp1_8 z?Ynz%U#?@o!=lhR9^za}VFmD%@3*Tyu~_Y9c-lFdITp(&tbCebvA3~BEyIKhufrbL2C@zd z(l zhFX7W49b6#dIAzOyf6U#LpRm@%bfEo|35Sa9=?v%3Bmy+5aIb?7oqlqUF0sh8K=4h z8FSvt-4isG+z91Xq8SdHLPE!3hDSsyl=f14yD9~59mBQma}TMuSZw#G3TV&TActa; z2g7of)MsGld!iE3V+`(zN8-!wU*r0y$5u2K5i|T)vvRP+hj1Y7u)JY$R}2I{S zfk&*!-4|fo(wo-|A#zt5odTV ztN@UyGLZeX!!?+I6c?eP$uM|>q3;IpP|)?4y7QNl9TWuZFer=?002CS38>;<=h*M6 zI0x}V6&JIKf55YJ8IUmZw%$w37x<9?7<_;a?f*Uc@|r@oTtUD2*25h5y72QV{5%Ib zL~}y-QOfS6%`?B0h2x`j?3kcqbz}@7POQmKqm-A#fMu^e+4E&49}0;rUGjDomD;U> zi>BvM&MUSw&4=G5zT2k9@iqGr@HC3=T`J6zLn$G~~szf`BQ z7WK73vQ=r4RNpvWcE!raw_vrC_=7Kgk!}4Whu80&T-pT=Rf*)F;@Dk40vLbCZDDBnEj_p z(3?$f%_AS`D|b^{_V3zs`}g2qdqdT0i!G2}An3^&x`B7&vAyr59T!kW^WI>fL+@s= z0*w9-weT;DUNSvso;8kb!0MF1kU3H~xSPQEPT#)1jV@<`SqBA?=UBAKLjpZ{d0>B1 z#P0z&VZaOQclQs*JaY{`O?q+&Y9G+O)&V_c?;; zff)axlx^d?H^V4{yy^2uhtq0`3usqXuik6v$G=u4=37oc9z?=fCZ|+lBdGl0OV6bq z7RvkM;MoyrfOqI-y#HZ8=mqcJcbfo$j8YxdQj28N7}rvYWz>jVDz4Be)}D`)Bh*ok z)KMRN!LF#o(5Ilo!KS3apn84i`T(=Wa~55NJ{4tURydb-gP5ehB&&A~#2=tFpf+&) z5BFbwLHa{We?@x%cL~6I4Zqg?Z-8JNl) zd~=e*wJ$X51TVLCx1&1)rmTt5&3VW5LOs9C+n4&Y^&jL}Yqt19Ce_e*|ZFtJ8 zcJ8bBgPwhgB35PQDE4jC4Sqx0R2zNx>|p}Uz7+YW#Vy%K8PoqyZD#>hW%jjkI;B&( zr5i~J3F+F$t5K#;g}DiRXXNQ=@f9U>ql-AE%K-*v_rE;0X^ar|K2wFH*uxA%MA zd){-;+0Sz}@b&-@8-%Nw`&khk!m_x&6iu`kp_6jbw;)9T8aG!7&(96Z>Dv1Z6!(JeyT$y7rYLoRKP zG*Nip@36|G23WU<%}$xJFBp44YTU(8%eD@u5)FyrSA9$>5lwZ1NlbAEu*K^q;e0R4 zGw+Lig;E2Gb^59pL;+Fkm|!}R=2~n+0FLuRQk3)=jP&q{xCJq;5W3N0qvGuh1v_`q zMCW8G(*muJOrIH`4ZszeEj3idEW-$PszdIt@=Aj}TTi9EHDoE?z=sEQ;+(8cspq4~ z@yL?7hC1065BK$yqeUNT=)x45?Hzy2ZafocRtnXb{>Y*Qwt^seuJE!?0R^|B3TI*7 zjXze7NQ$xwkINW`Cd*LikRvqGr)C-XQg6K&Q&}@cp^&jg;rtb|VQqomw4%Ds^sYkh zHxA?2(Z}UzJU;knU=pL5$V-+(G_Qy|MmrOnJMMS35Mc=Suswjzg4J|{ ziE{HXEJ^fHFN>?I;<-I{Pv3B|nw%9~KW$HN~=ext1EhHVyWE zVSqLv(Zu^#9a0pJ14~QO<7fNph~#W72u^!D&WKHSJMJ7!CQH6)E>&ow7w#a-fkY}X z69wCA4G@5ggu~%_l1#K0RygQ$|CFhvgeG;(bDM$ngZndGk>=PD=05doN~1-V&~?d| z6^X$Gqn@gtS?XIi;TW0ZhMC->p&rB!46`D3r{|QYzHP8ecEFf#d}74&P-|MgKaO>T zTqPZgAL@RGqwc!~aCGd~t<$X;4A}dVpO+lIXw@9CX+3$24Zw#4)F?g@TatCKT^*lddG>sizPh1ZlSkU))BS-HROGSp%;)W+C9?I_vK-xE1~I z(BO62>;2$QGf2iTyHx%eMi4w>lMQ+F59?r#E-adjluN-svLVv)qKCextOo?B z7$^H|yDO9j-yc8cK105keB!csU9$Bv{JVMI_vK5+8;tnK85!xm7q0_nf4`gcUH<8} z5tPxyz}XGB_+t5EE(q!jhyon0qZjDXzCTv%fiH%C7Kp{4%c(!wR8mv~D%uu57u+pZ zp%rJK?d?+B{pAbwbmZ%fcN zeYL7Hy_i_=NLgUmbCk`nP0PgF-6t@I>OE&(2!6nh-|N@SgPwY&YJTS*wQR8C?-H(5 zf2*w>)hbgu2!RbW<=2=>>&}nR(Zbb(YZ6OX>>Y|ar}E6jo59{iV`)&kbC+Apfx@!8 zPCv)}TcX(>p3TS+{KcEsDB|*)SNES?@gH`bdcT`9{MqF{eoc47pZ|R0g7&vPx}Rnw z^Zl0uz#G8{2@H(=Z|T4lSD;NOlhI{Mk&T3DpbrFU`!wV+F*1|fV?L*em~>lsE%k)g zt@2`O{)W#n&@^1EYGjzdO}jo_IC?OMg1Sw$Od7L(DK29T3DA+ngwVbO<~mss>4N20is|v+$eUCkYyFi-s_|b3fa}NB7DWs zdd2cy%trQS}{O9&W`tK?B%^bZn<f2 z4Tx>r{+jw^MhU4=VZS-1pAJ>h0K!AJF933#QBd303_MCn0n-+&m4<@9J{T&*EpUvUIGbou$Y@&x#FU)3cVwJckjUv| zBE6CDrD(_qM)HeaPK1-8p@?hY*xTZLNv(nNKEbGJto-1yaa1#DE4Qgr&~{X|B%L^v zUITknnklA}gB<-ZHCeQ3!y=%-pt$+_1I5yN4UCT$O#e z{5^>-Y)tQ;s8+)`sjZQb!3e$J!cbmd&ZFXLy!{$8VzT>A42ACSBGahg7JpM=7Zulv z1BDpGwp0qD_rhF+drgGa;X`KTQg~~thygW6s5|D8_FkJpfJu`2IT!zdSI5I4yUUu% zx`4r3_76?8My<3t#>X(@+i;hK2U3d1V3Lf;K1633+>TX2Bnz^`VsD!ltjX};c{=7K zX*@C1Mrc{PX7k*#_|pg~s=XwXp?*!}sEmCmet~5*%ZrSS#hugLvHce%Z*jekJzZF! z_M$45Mk#pxNP$5iZ^3W1qTWbh90;Cj$n+0*e6WzB&Be2m zyCQp)-sM*7BbkV3QHFe0Sbaj@sQOh98i8^?2(^t>HWyvM{3ZO?20}6JK*`tDGL$2M zU!}9D#{)7Hvd73HRaB*pox*gzWo+Rq zhAxuKvK^x8EiYU~I^Zh~<>_l?*o1s0ljFaQ1J;*TNT4e`Ti4M1K-k^^Y#IfzE^jEq zPKCG*8Nk8SYj1ojYSHeMDjdB>vb=H$ahsJ5e#p|0KDb*JPZNx+Nh7$OEo}9ML=kdU z(V64!NbPc3F)tM4^fM@yexh>lG6t`dkc@~>VGN4akmRJ~KFPk1ao%E3yq%Wi)KlsU zQc%j7>3B%87`&a52w3>F5NKo)Ay^dNe5m>{l$P-SC4$-T&`IST!i6^Rj58XtHOXg_pN*El4mK0TN-(XX@(^_JNdsvEY+FCU$>oXF|d zX2qP}6+Ps^`w3z-hU9# zLY>Dk?~`$O_|0f`X}?~tB~}U3wL(DuNDrilm9NxK6XyIY_bhPJHJJP#)NA}0x|#l% zk^C_I1D-!;V0CFcPqzMT2BF6kxn*Y**p$YUT!*;c`VoRos&>F6b^s>xqa=>i&@P&Ga93*f16qwN=!+%g;q zz+Wgrcf$hBUSyk^Z)d-Nv5O8{v!Z_M?&7opw{pbC$>$hJl2&IbGrNBF>K>Wfwwgze zQt?|U?&mdP*+jGa+$&CEiqZtTNV3esB-4R+B%*mzDc+^NXB81LQZ$RA5Z6SIn1WF% zv^wZ=!JxO*Cx;8??SE0qO{?l+f8IKL*j?zPNJ+1?y@+0fkOlB{5OsxLDjf*!Qhd9= zPY*+nU8y}@pa*5Q=pgBdsacJxi+(~xS2&yQNm`nIzMtpnesa4>PVeMwGlyxC7&U0o z3tM!XsHpDnYr?zt-iM3AC{1gdI$Jw$5IqCh6ant99OB4{>V|dCf7ifOU(x6fdTXo=xL*INGw?O&>t0of`)q82WBDo@} zMOICfy8EwLcHy@^-eudAtZLmr%pDCWwR}fJujY4@9o=H8;TbOkw`D^b(2;?)Xf7>V z=T*HjQTtR@W2$nFJ|FFYIa!6yZf{w+O6h*e$^(+rc6N+9^U6tIvl1bFlo^Z97N2z) z?Q`1i7rkR}*nr}3#$B~ow^-L@c6l(jX{fcy*!8LLHb2Uym^Ew@z9Cr-pf@3v=X+csoK^ zM`Np%l}{_ipi17Ho3II6YV@hz6DDvA$~~fV2XK>%WQQqj-r0~*?BvW)GlB*!(m{~PtPAfke{cLwG6j3 zwSvvfI6bT&tm;ui+_ThQ)fU7jCg!#69di8q1|Fe49UR85K1W1fo>WCW@9f>#y&y4l zD(V*BEwn(JQFhEbug~uFw|D!8p)w5%QZZ`;xP9&f$w3de$n|M3JWTu)3PyuH-##ecCUqn`G$i z>g=ZsAIdgM7_F4XU+W;-VJe0tB9~j?x%D1~t7vl9$E!Otq}tl7me(LqCH; zUjl80A6*uhXkH!?g-qKDO#;t?_69NAEg*@(s-i3-S%;|Ga}%%Ie<6uqv^nrSXW&D* zH+Rn3qjWXrU-jGga~2nYze7EFyku(Jl-S!6<<%eCj{H?3wIbZNJVKJB`3#IKHMw=V z$s4*Loo$$yELcQP`GG&dPOMn}D7;Q5asefh$EJ&KEmkTtO>}dEH}B`BDQfG!)eal} zEun&#XU7MRbI_Ye(W!^WY$;)EMlqI|P&OtJN`T5Z_s%MY<6_+%YpJO(K+8mjbB#LZ zP64;hX$P+Z$>ha*Yz*Is3>w6x@3$!HOEyYCbJL*6Jjskk!xSsZEl`f5iv@7H68SRt zEE?4$cw$5|VV(_J)-5m#Y(G8e9`BB_p5UZ2S0GJaADppwca-9uj5~atMosqAE{GZv zG13=Po!I^OzGYJBr=74KV_OG6sH(Iq+1Uv^^# zLz?AyXuR_$)x_Zzg*<5I^7GhH%2*4gSyg*4rV}ZYe zySs|gLM~m(*e5A~Ha&epe6h$RTjH&0=P=@S3|!I^0*<;||MG)3=rYrf&)?5uCoF(I z%|Tm-G(jzql{5Ekp=+o`KWi-Om(Hr`N z(xSWP=P9g9mb}a{i&@oJ`=vjc;G&C7&#YT5!^=e5NihuE!w#`54b0Zna*W$t>yU|& zs-?L#%NnT~D8KKe#rQbnQC84I zYbK_7Q6#yQiKh(`GdeQv@Wci#{T3~`O?6}Ko9(-wkm*wh6YbV_N$$J$+oZ)XnuQ^` zAx0z`@fe!kR_rVDKO8bXNf}FralsN^Xz@+?p!Gu9+h;vnoSgri)fiJlW77mp1tF0P zQZBpn@3vk8N~|78+0U94$tLLyk;;;zyFKF9F|a*+{$yR&=1 zqE4#6ysLgp{(nDQ2zbQak9(+4b;4#s4ApB%O}YodJT5w7D8np{gtHdFO2<1P3h7H_t4cAG={<$^7tMUWH*PbwIFz$@tfq(l zZS$*#+qd;&IZ`UysRqJFPr(^qW-L{;p~^MZfV+6`9lW8<^6<^yqdkja>-?OJnQEri zfMcA_yG4dmlu+RSGHbQ)y zcCA??lgW25ur)9Vlix|;%SGu8zKBtRDTr+>SNiB2tt|Fp7QXfcz{DBMQ?DbkP63WX)SmYh4yi89h!{)0 z^?zOiVSr;ZjkTWe^reJJ?+AC+OINVrFE5dUe9VLw&NMkKeR(q4*k$y#$_fCet2y;d zX2X^0uq>f~y#&wT*P)0Mbmi=!T7oOq2eLw?k{kjJ^XzSqU|EhIRM{-ceb<1c_NEPr# z`=2TNxpR6^LUb*U>jtl&2&>!w9s%l~de!a~G`Z_ut)OIly#Gf2qr~tk@vt#YPy##BSDGtzleBave!KzLD3N;KcDPhIznE}{IU}yC?1ydm*Fq_LS7Bw zvWp{V2)+MbA>7y-zgd!8vR?#^B^|h9`;+%Q@c9X9#t54Kcjjd)LQp0=#jj%CnDBK& zK2W$X3hg3S6Q3ufX36he3(I_30&>8Bk(4(@zsG8L(U>UNw2SVEQrt z8sd%pd6UJ;1=^eCr_p~Ju7DKYTlQ{$e_%fpJ!f|2Vccr)**vpZ3KQg)$7Tj#6|46F>8pHR?cU7fw5d|6W*pq*7`TkO~0!q3`opC{m1)d)A4@iHMKK_JO12mSK zv>F$&pez4fEH^7RKnd6D^Do*51M>yi3H|SEFPCXuTQR?0I||you=c-e{*U9MFDgkv zQ@LJa2FiM(|1&I*iZf8u_2LRp)UoluM1kBTpp@&I?VuDnv%jKT+GGN5y~|5M!+igr Q_kiCPz=ivlR^Na6KT%u?`2YX_ literal 0 HcmV?d00001 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm deleted file mode 100644 index d7a828a4..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm +++ /dev/null @@ -1,7408 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2023 -# -# @@ Meta Begin -# Application textblock 0.1.1 -# Meta platform tcl -# Meta license -# @@ Meta End - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_textblock 0 0.1.1] -#[copyright "2024"] -#[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] -#[require textblock] -#[keywords module utility lib] -#[description] -#[para] Ansi-aware terminal textblock manipulation - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of textblock -#[subsection Concepts] -#[para] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by textblock -#[list_begin itemized] - -#*** !doctools -#[item] [package {Tcl 8.6-}] -#[item] [package {punk::args}] -#[item] [package {punk::char}] -#[item] [package {punk::ansi}] -#[item] [package {punk::lib}] -#[item] [package {overtype}] -#[item] [package {term::ansi::code::macros}] -#[item] [package {textutil}] - -## Requirements -package require Tcl 8.6- -package require punk::args -package require punk::char -package require punk::ansi -package require punk::lib -catch {package require patternpunk} -package require overtype - -#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. -package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? -package require textutil - - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -tcl::namespace::eval textblock { - #review - what about ansi off in punk::console? - tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ - tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock - variable use_md5 ;#framecache - set use_md5 1 - if {[catch {package require md5}]} { - set use_md5 0 - } - proc use_md5 {{yes_no ""}} { - variable use_md5 - if {$yes_no eq ""} { - return $use_md5 - } - if {![string is boolean -strict $yes_no]} { - error "textblock::use_md5 requires a boolean (or empty string to query)" - } - if {$yes_no} { - package require md5 - set use_md5 1 - } else { - set use_md5 0 - } - return $use_md5 - } - tcl::namespace::eval class { - variable opts_table_defaults - set opts_table_defaults [tcl::dict::create\ - -title ""\ - -titlealign "left"\ - -titletransparent 0\ - -frametype "light"\ - -frametype_header ""\ - -ansibase_header ""\ - -ansibase_body ""\ - -ansibase_footer ""\ - -ansiborder_header ""\ - -ansiborder_body ""\ - -ansiborder_footer ""\ - -ansireset "\uFFeF"\ - -framelimits_header "vll vlr hlb hlt tlc trc blc brc"\ - -frametype_body ""\ - -framelimits_body "vll vlr hlb hlt tlc trc blc brc"\ - -framemap_body [list\ - topleft {} topinner {} topright {} topsolo {}\ - middleleft {} middleinner {} middleright {} middlesolo {}\ - bottomleft {} bottominner {} bottomright {} bottomsolo {}\ - onlyleft {} onlyinner {} onlyright {} onlysolo {}\ - ]\ - -framemap_header [list\ - topleft {} topinner {} topright {} topsolo {}\ - middleleft {} middleinner {} middleright {} middlesolo {}\ - bottomleft {} bottominner {} bottomright {} bottomsolo {}\ - onlyleft {} onlyinner {} onlyright {} onlysolo {}\ - ]\ - -show_edge 1\ - -show_seps 1\ - -show_hseps ""\ - -show_vseps ""\ - -show_header ""\ - -show_footer ""\ - -minwidth ""\ - -maxwidth ""\ - ] - variable opts_column_defaults - set opts_column_defaults [tcl::dict::create\ - -headers [list]\ - -header_colspans [list]\ - -footers [list]\ - -defaultvalue ""\ - -ansibase ""\ - -ansireset "\uFFEF"\ - -minwidth ""\ - -maxwidth ""\ - -blockalign centre\ - -textalign left\ - ] - #initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only - - - - #for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns) - #ie only vll,blc,hlb used for cells except top row and right column - #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) - #right cells use 'U' shape (vll,blc,hlb,brc,vlr) - #e.g for 4x4 - # C C C O - # L L L U - # L L L U - #anti-clockwise elements - set C [list hlt tlc vll blc hlb] - set O [list trc hlt tlc vll blc hlb brc vlr] - set L [list vll blc hlb] - set U [list vll blc hlb brc vlr] - set tops [list trc hlt tlc] - set lefts [list tlc vll blc] - set bottoms [list blc hlb brc] - set rights [list trc brc vlr] - - variable table_edge_parts - set table_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - middleleft [struct::set intersect $L $lefts]\ - middleinner [list]\ - middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts $bottoms]]\ - bottominner [struct::set intersect $L $bottoms]\ - bottomright [struct::set intersect $U [concat $bottoms $rights]]\ - bottomsolo [struct::set intersect $U [concat $lefts $bottoms $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts $bottoms]]\ - onlyinner [struct::set intersect $C [concat $tops $bottoms]]\ - onlyright [struct::set intersect $O [concat $tops $bottoms $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $bottoms $rights]]\ - ] - - #for header rows - we don't consider the bottom border as part of the edge - even if table body has no rows - #The usual-case of a single header line is the 'onlyleft,onlyinner,onlyright,onlysolo' set. - variable header_edge_parts - set header_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - middleleft [struct::set intersect $L $lefts]\ - middleinner [list]\ - middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts]]\ - bottominner [list]\ - bottomright [struct::set intersect $U $rights]\ - bottomsolo [struct::set intersect $U [concat $lefts $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts]]\ - onlyinner [struct::set intersect $C $tops]\ - onlyright [struct::set intersect $O [concat $tops $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - ] - variable table_hseps - set table_hseps [tcl::dict::create\ - topleft [list blc hlb]\ - topinner [list blc hlb]\ - topright [list blc hlb brc]\ - topsolo [list blc hlb brc]\ - middleleft [list blc hlb]\ - middleinner [list blc hlb]\ - middleright [list blc hlb brc]\ - middlesolo [list blc hlb brc]\ - bottomleft [list]\ - bottominner [list]\ - bottomright [list]\ - bottomsolo [list]\ - onlyleft [list]\ - onlyinner [list]\ - onlyright [list]\ - onlysolo [list]\ - ] - variable table_vseps - set table_vseps [tcl::dict::create\ - topleft [list]\ - topinner [list vll tlc blc]\ - topright [list vll tlc blc]\ - topsolo [list]\ - middleleft [list]\ - middleinner [list vll tlc blc]\ - middleright [list vll tlc blc]\ - middlesolo [list]\ - bottomleft [list]\ - bottominner [list vll tlc blc]\ - bottomright [list vll tlc blc]\ - bottomsolo [list]\ - onlyleft [list]\ - onlyinner [list vll tlc blc]\ - onlyright [list vll tlc blc]\ - onlysolo [list]\ - ] - - #ensembles seem to be not compiled in safe interp - #https://core.tcl-lang.org/tcl/tktview/1095bf7f75 - #as we want textblock to be usable in safe interps - use tcl::dict::for as a partial workaround - #This at least means the script argument, especially switch statements can get compiled. - #It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp. - - #e.g $t configure -framemap_body [table_edge_map " "] - proc table_edge_map {char} { - variable table_edge_parts - set map [list] - tcl::dict::for {celltype parts} $table_edge_parts { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - proc table_sep_map {char} { - variable table_hseps - set map [list] - tcl::dict::for {celltype parts} $table_hseps { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - proc header_edge_map {char} { - variable header_edge_parts - set map [list] - tcl::dict::for {celltype parts} $header_edge_parts { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - - if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} { - #*** !doctools - #[subsection {Namespace textblock::class}] - #[para] class definitions - #[list_begin itemized] [comment {- textblock::class groupings -}] - # [item] - # [para] [emph {handler_classes}] - # [list_begin enumerated] - - #this makes new table objects a little faster when multiple opts specified as well as to configure - #as tables are a heavyweight thing, but handy to nest sometimes - we'll take what we can get - set topt_keys [tcl::dict::keys $::textblock::class::opts_table_defaults] - set switch_keys_valid_topts [punk::lib::lmapflat v $topt_keys {list $v -}] - set switch_keys_valid_topts [lrange $switch_keys_valid_topts 0 end-1] ;#remove last dash - - set copt_keys [tcl::dict::keys $::textblock::class::opts_column_defaults] - set switch_keys_valid_copts [punk::lib::lmapflat v $copt_keys {list $v -}] - set switch_keys_valid_copts [lrange $switch_keys_valid_copts 0 end-1] - - oo::class create [tcl::namespace::current]::table [tcl::string::map [list %topt_keys% $topt_keys %topt_switchkeys% $switch_keys_valid_topts %copt_keys% $copt_keys %copt_switchkeys% $switch_keys_valid_copts] { - #*** !doctools - #[enum] CLASS [class textblock::class::table] - #[list_begin definitions] - # [para] [emph METHODS] - variable o_opts_table ;#options as configured by user (with exception of -ansireset) - variable o_opts_table_effective; #options in effect - e.g with defaults merged in. - - variable o_columndefs - variable o_columndata - variable o_columnstates - variable o_headerstates - - variable o_rowdefs - variable o_rowstates - - variable o_opts_table_defaults - variable o_opts_header_defaults ;# header data mostly stored in o_columndefs - variable o_opts_column_defaults - variable o_opts_row_defaults - variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap) - variable o_calculated_column_widths - variable o_column_width_algorithm - - - constructor {args} { - #*** !doctools - #[call class::table [method constructor] [arg args]] - set o_opts_table_defaults $::textblock::class::opts_table_defaults - set o_opts_column_defaults $::textblock::class::opts_column_defaults - - - if {[llength $args] == 1} { - set args [list -title [lindex $args 0]] - } - if {[llength $args] %2 !=0} { - error "[tcl::namespace::current]::table constructor - unexpected argument count. Require single value being title, or name value pairs" - } - - set o_opts_table $o_opts_table_defaults - set o_opts_table_effective $o_opts_table_defaults - - ##todo - test with punk::lib::show_jump_tables - how? - foreach {k v} $args { - switch -- $k { - %topt_switchkeys% { - tcl::dict::set o_opts_table $k $v - } - default { - error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - } - my configure {*}$o_opts_table - - #foreach {k v} $args { - # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. - # if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { - # error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - # } - #} - #set o_opts_table [tcl::dict::merge $o_opts_table_defaults $args] - #my configure {*}[tcl::dict::merge $o_opts_table_defaults $args] - - set o_columndefs [tcl::dict::create] - set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row - set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly - set o_headerstates [tcl::dict::create] - set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight - set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data - - set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices. - set o_calculated_column_widths [list] - set o_column_width_algorithm "span" - set header_defaults [tcl::dict::create\ - -colspans {}\ - -values {}\ - -ansibase {}\ - ] - set o_opts_header_defaults $header_defaults - } - - method width_algorithm {{alg ""}} { - if {$alg eq ""} { - return $o_column_width_algorithm - } - if {$alg ne $o_column_width_algorithm} { - #invalidate cached widths - set o_calculated_column_widths [list] - } - set o_column_width_algorithm $alg - } - method Get_seps {} { - set requested_seps [tcl::dict::get $o_opts_table -show_seps] - set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] - set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] - set seps $requested_seps - set seps_h $requested_seps_h - set seps_v $requested_seps_v - if {$requested_seps eq ""} { - if {$requested_seps_h eq ""} { - set seps_h 1 - } - if {$requested_seps_v eq ""} { - set seps_v 1 - } - } else { - if {$requested_seps_h eq ""} { - set seps_h $seps - } - if {$requested_seps_v eq ""} { - set seps_v $seps - } - } - return [tcl::dict::create horizontal $seps_h vertical $seps_v] - } - method Get_frametypes {} { - set requested_ft [tcl::dict::get $o_opts_table -frametype] - set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] - set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] - set ft $requested_ft - set ft_header $requested_ft_header - set ft_body $requested_ft_body - switch -- $requested_ft { - light { - if {$requested_ft_header eq ""} { - set ft_header heavy - } - if {$requested_ft_body eq ""} { - set ft_body light - } - } - default { - if {$requested_ft_header eq ""} { - set ft_header $requested_ft - } - if {$requested_ft_body eq ""} { - set ft_body $requested_ft - } - } - } - return [tcl::dict::create header $ft_header body $ft_body] - } - method Set_effective_framelimits {} { - upvar ::textblock::class::opts_table_defaults tdefaults - set default_blims [tcl::dict::get $tdefaults -framelimits_body] - set default_hlims [tcl::dict::get $tdefaults -framelimits_header] - set eff_blims [tcl::dict::get $o_opts_table_effective -framelimits_body] - set eff_hlims [tcl::dict::get $o_opts_table_effective -framelimits_header] - - set requested_blims [tcl::dict::get $o_opts_table -framelimits_body] - set requested_hlims [tcl::dict::get $o_opts_table -framelimits_header] - set blims $eff_blims - set hlims $eff_hlims - switch -- $requested_blims { - "default" { - set blims $default_blims - } - default { - #set blims $requested_blims - set blims [list] - foreach lim $requested_blims { - switch -- $lim { - hl { - lappend blims hlt hlb - } - vl { - lappend blims vll vlr - } - default { - lappend blims $lim - } - } - } - set blims [lsort -unique $blims] - } - } - tcl::dict::set o_opts_table_effective -framelimits_body $blims - switch -- $requested_hlims { - "default" { - set hlims $default_hlims - } - default { - #set hlims $requested_hlims - set hlims [list] - foreach lim $requested_hlims { - switch -- $lim { - hl { - lappend hlims hlt hlb - } - vl { - lappend hlims vll vlr - } - default { - lappend hlims $lim - } - } - } - set hlims [lsort -unique $hlims] - } - } - tcl::dict::set o_opts_table_effective -framelimits_header $hlims - return [tcl::dict::create body $blims header $hlims] - } - method configure args { - if {![llength $args]} { - return $o_opts_table - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [list %topt_keys%]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_opts_table $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { - tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "[tcl::namespace::current]::table configure - unexpected argument count. Require name value pairs" - } - foreach {k v} $args { - switch -- $k { - %topt_switchkeys% {} - default { - error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - #if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { - # error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - #} - } - set checked_opts [list] - foreach {k v} $args { - switch -- $k { - -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set ansi_codes [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend ansi_codes $code - } - } - set ansival [punk::ansi::codetype::sgr_merge_singles $ansi_codes] - lappend checked_opts $k $ansival - } - -frametype - -frametype_header - -frametype_body { - #frametype will raise an error if v is not a valid custom dict or one of the known predefined types such as light,heavy,double etc - lassign [textblock::frametype $v] _cat category _type ftype - lappend checked_opts $k $v - } - -framemap_body - -framemap_header { - #upvar ::textblock::class::opts_table_defaults tdefaults - #set default_bmap [tcl::dict::get $tdefaults -framemap_body] - #todo - check keys and map - if {[llength $v] == 1} { - if {$v eq "default"} { - upvar ::textblock::class::opts_table_defaults tdefaults - set default_map [tcl::dict::get $tdefaults $k] - lappend checked_opts $k $default_map - } else { - error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}" - } - } else { - #safe jumptable test - #dict for {subk subv} $v {} - foreach {subk subv} $v { - switch -- $subk { - topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} - default { - error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" - } - } - #safe jumptable test - #dict for {seg subst} $subv {} - foreach {seg subst} $subv { - switch -- $seg { - hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {} - default { - error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}" - } - } - } - - } - lappend checked_opts $k $v - } - - } - -framelimits_body - -framelimits_header { - set specific_framelimits [list] - foreach fl $v { - switch -- $fl { - "default" { - lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr - } - hl { - lappend specific_framelimits hlt hlb - } - vl { - lappend specific_framelimits vll vlr - } - hlt - hlb - vll - vlr - trc - tlc - blc - brc { - lappend specific_framelimits $fl - } - default { - error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)" - } - } - } - lappend checked_opts $k $specific_framelimits - } - -ansireset { - if {$v eq "\uFFEF"} { - set RST "\x1b\[m" ;#[a] - lappend checked_opts $k $RST - } else { - error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -show_hseps { - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - lappend checked_opts $k $v - #these don't affect column width calculations - } - -show_edge { - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - lappend checked_opts $k $v - #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - } - -show_vseps { - #we allow empty string - so don't use -strict boolean check - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - #affects width calculations - set o_calculated_column_widths [list] - lappend checked_opts $k $v - } - -minwidth - -maxwidth { - set o_calculated_column_widths [list] - lappend checked_opts $k $v - } - default { - lappend checked_opts $k $v - } - } - } - #all options checked - ok to update o_opts_table and o_opts_table_effective - - #set o_opts_table [tcl::dict::merge $o_opts_table $checked_opts] - foreach {k v} $args { - switch -- $k { - -framemap_header - -framemap_body { - #framemaps don't require setting every key to update. - #e.g configure -framemaps {topleft } - #needs to merge with existing unspecified keys such as topright middleleft etc. - if {$v eq "default"} { - tcl::dict::set o_opts_table $k default - } else { - if {[tcl::dict::get $o_opts_table $k] eq "default"} { - tcl::dict::set o_opts_table $k $v - } else { - tcl::dict::set o_opts_table $k [tcl::dict::merge [tcl::dict::get $o_opts_table $k] $v] - } - } - } - default { - tcl::dict::set o_opts_table $k $v - } - } - } - #use values from checked_opts for the effective opts - #safe jumptable test - #dict for {k v} $checked_opts {} - #foreach {k v} $checked_opts {} - tcl::dict::for {k v} $checked_opts { - switch -- $k { - -framemap_body - -framemap_header { - set existing [tcl::dict::get $o_opts_table_effective $k] - #set updated $existing - #dict for {subk subv} $v { - # tcl::dict::set updated $subk $subv - #} - #tcl::dict::set o_opts_table_effective $k $updated - tcl::dict::set o_opts_table_effective $k [tcl::dict::merge $existing $v] - } - -framelimits_body - -framelimits_header { - #my Set_effective_framelimits - tcl::dict::set o_opts_table_effective $k $v - } - default { - tcl::dict::set o_opts_table_effective $k $v - } - } - } - #ansireset exception - tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] - return $o_opts_table - } - - #integrate with struct::matrix - allows ::m format 2string $table - method printmatrix {matrix} { - set matrix_rowcount [$matrix rows] - set matrix_colcount [$matrix columns] - set table_colcount [my column_count] - if {$table_colcount == 0} { - for {set c 0} {$c < $matrix_colcount} {incr c} { - my add_column -headers "" - } - } - set table_colcount [my column_count] - if {$table_colcount != $matrix_colcount} { - error "textblock::table::printmatrix column count of table doesn't match column count of matrix" - } - if {[my row_count] > 0} { - my row_clear - } - for {set r 0} {$r < $matrix_rowcount} {incr r} { - my add_row [$matrix get row $r] - } - my print - } - method as_matrix {{cmd ""}} { - if {$cmd eq ""} { - set m [struct::matrix] - } else { - set m [struct::matrix $cmd] - } - $m add columns [tcl::dict::size $o_columndata] - $m add rows [tcl::dict::size $o_rowdefs] - tcl::dict::for {k v} $o_columndata { - $m set column $k $v - } - return $m - } - method add_column {args} { - #*** !doctools - #[call class::table [method add_column] [arg args]] - - - if {[llength $args] %2 != 0} { - error "[tcl::namespace::current]::table::add_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" - } - set opts $o_opts_column_defaults - foreach {k v} $args { - switch -- $k { - %copt_switchkeys% { - tcl::dict::set opts $k $v - } - default { - error "[tcl::namespace::current]::table::add_column unknown option '$k'. Known options: %copt_keys%" - } - } - } - set colcount [tcl::dict::size $o_columndefs] - - - tcl::dict::set o_columndata $colcount [list] - #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists - tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists - - - tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] - set prev_calculated_column_widths $o_calculated_column_widths - if {[catch { - my configure_column $colcount {*}$opts - } errMsg]} { - #configure failed - ensure o_columndata and o_columndefs entries are removed - tcl::dict::unset o_columndata $colcount - tcl::dict::unset o_columndefs $colcount - tcl::dict::unset o_columnstates $colcount - #undo cache invalidation - set o_calculated_column_widths $prev_calculated_column_widths - error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" - } - #any add_column that succeeds should invalidate the calculated column widths - set o_calculated_column_widths [list] - set numrows [my row_count] - if {$numrows > 0} { - #fill column with default values - #puts ">>> adding default values for column $colcount" - set dval [tcl::dict::get $opts -defaultvalue] - set width [textblock::width $dval] - tcl::dict::set o_columndata $colcount [lrepeat $numrows $dval] - tcl::dict::set o_columnstates $colcount maxwidthbodyseen $width - tcl::dict::set o_columnstates $colcount minwidthbodyseen $width - } - return $colcount - } - method column_count {} { - return [tcl::dict::size $o_columndefs] - } - method configure_column {index_expression args} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" - } - if {![llength $args]} { - return [tcl::dict::get $o_columndefs $cidx] - } else { - if {[llength $args] == 1} { - if {[lindex $args 0] in [list %copt_keys%]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_columndefs $cidx $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - } else { - error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values %copt_keys%" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" - } - foreach {k v} $args { - switch -- $k { - %copt_switchkeys% {} - default { - error "[tcl::namespace::current]::table configure_column unknown option '$k'. Known options: %copt_keys%" - } - } - } - set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state - - set hstates $o_headerstates ;#operate on a copy - set colstate [tcl::dict::get $o_columnstates $cidx] - set args_got_headers 0 - set args_got_header_colspans 0 - foreach {k v} $args { - switch -- $k { - -headers { - set args_got_headers 1 - set i 0 - set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. - foreach hdr $v { - set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns - #set this_header_height [textblock::height $hdr] - lassign [textblock::size $hdr] _w this_header_width _h this_header_height - - if {$this_header_height >= $currentmax} { - tcl::dict::set hstates $i maxheightseen $this_header_height - } else { - tcl::dict::set hstates $i maxheightseen $currentmax - } - if {$this_header_width >= $maxseen} { - set maxseen $this_header_width - } - #if {$this_header_width > [tcl::dict::get $colstate maxwidthheaderseen]} { - # tcl::dict::set colstate maxwidthheaderseen $this_header_width - #} - incr i - } - tcl::dict::set colstate maxwidthheaderseen $maxseen - #review - we could avoid some recalcs if we check current width range compared to previous - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -header_colspans { - set args_got_header_colspans 1 - #check columns to left to make sure each new colspan for this column makes sense in the overall context - #user may have to adjust colspans in order left to right to avoid these check errors - #note that 'any' represents span all up to the next non-zero defined colspan. - set cspans [my header_colspans] - set h 0 - if {[llength $v] > [tcl::dict::size $cspans]} { - error "configure_column $cidx -header_colspans. Only [tcl::dict::size $cspans] headers exist. Too many values supplied" - } - foreach s $v { - if {$cidx == 0} { - if {[tcl::string::is integer -strict $s]} { - if {$s < 1} { - error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'any' or a positive integer" - } - } else { - if {$s ne "any" && $s ne ""} { - error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" - } - } - } else { - #if {![tcl::string::is integer -strict $s]} { - # if {$s ne "any" && $s ne ""} { - # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" - # } - #} else { - set header_spans [tcl::dict::get $cspans $h] - set remaining [lindex $header_spans 0] - if {$remaining ne "any"} { - incr remaining -1 - } - #look at spans defined for previous cols - #we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption - for {set c 0} {$c < $cidx} {incr c} { - set span [lindex $header_spans $c] - if {$span eq "any"} { - set remaining "any" - } else { - if {$remaining eq "any"} { - if {$span ne "0"} { - #a previous column has ended the 'any' span - set remaining [expr {$span -1}] - } - } else { - if {$span eq "0"} { - incr remaining -1 - } else { - set remaining [expr {$span -1}] - } - #allow to go negative - } - } - } - if {$remaining eq "any"} { - #any int >0 ok - what about 'any' immediately following any? - } else { - if {$remaining > 0} { - if {$s ne "0" && $s ne ""} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. Remaining span is '$remaining' - so a zero colspan is required" - } - } else { - if {$s == 0} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" - } - } - } - #} - } - incr h - } - #todo - avoid recalc if no change - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -minwidth { - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -maxwidth { - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set col_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend col_ansibase_items $code - } - } - set col_ansibase [punk::ansi::codetype::sgr_merge_singles $col_ansibase_items] - tcl::dict::set checked_opts $k $col_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - tcl::dict::set checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -blockalign - -textalign { - switch -- $v { - left - right { - tcl::dict::set checked_opts $k $v - } - centre - centre { - tcl::dict::set checked_opts $k centre - } - } - } - default { - tcl::dict::set checked_opts $k $v - } - } - } - #args checked - ok to update headerstates and columndefs and columnstates - tcl::dict::set o_columndefs $cidx $checked_opts - - set o_headerstates $hstates - tcl::dict::set o_columnstates $cidx $colstate - - if {$args_got_headers} { - #if the headerlist length for this column has shrunk,and it was the longest - we may now have excess entries in o_headerstates - set zero_heights [list] - tcl::dict::for {hidx _v} $o_headerstates { - #pass empty string for exclude_column so we don't exclude our own column - if {[my header_height_calc $hidx ""] == 0} { - lappend zero_heights $hidx - } - } - foreach zidx $zero_heights { - tcl::dict::unset o_headerstates $zidx - } - } - if {$args_got_headers || $args_got_header_colspans} { - #check and adjust header_colspans for all columns - - } - - return [tcl::dict::get $o_columndefs $cidx] - } - } - - method header_count {} { - return [tcl::dict::size $o_headerstates] - } - method header_count_calc {} { - set max_headers 0 - tcl::dict::for {k cdef} $o_columndefs { - set num_headers [llength [tcl::dict::get $cdef -headers]] - set max_headers [expr {max($max_headers,$num_headers)}] - } - return $max_headers - } - method header_height {header_index} { - set idx [lindex [tcl::dict::keys $o_headerstates $header_index]] - return [tcl::dict::get $o_headerstates $idx maxheightseen] - } - - #review - use maxwidth (considering colspans) of each column to determine height after wrapping - # -need to consider whether vertical expansion allowed / maxheight? - method header_height_calc {header_index {exclude_column ""}} { - set dataheight 0 - if {$exclude_column eq ""} { - set exclude_colidx "" - } else { - set exclude_colidx [lindex [tcl::dict::keys $o_columndefs] $exclude_column] - } - tcl::dict::for {cidx cdef} $o_columndefs { - if {$exclude_colidx == $cidx} { - continue - } - set headerlist [tcl::dict::get $cdef -headers] - if {$header_index < [llength $headerlist]} { - set this_height [textblock::height [lindex $headerlist $header_index]] - set dataheight [expr {max($dataheight,$this_height)}] - } - } - return $dataheight - } - - #return a dict keyed on header index with values representing colspans - #e.g - # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} - # - method header_colspans {} { - #set num_headers [my header_count_calc] - set num_headers [my header_count] - set colspans_by_header [tcl::dict::create] - tcl::dict::for {cidx cdef} $o_columndefs { - set headerlist [tcl::dict::get $cdef -headers] - set colspans_for_column [tcl::dict::get $cdef -header_colspans] - for {set h 0} {$h < $num_headers} {incr h} { - set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] - set defined_span [lindex $colspans_for_column $h] - set i 0 - set spanremaining [lindex $headerspans 0] - if {$spanremaining ne "any"} { - if {$spanremaining eq ""} { - set spanremaining 1 - } - incr spanremaining -1 - } - foreach s $headerspans { - if {$s eq "any"} { - set spanremaining "any" - } elseif {$s == 0} { - if {$spanremaining ne "any"} { - incr spanremaining -1 - } - } else { - set spanremaining [expr {$s - 1}] - } - incr i - } - if {$defined_span eq ""} { - if {$spanremaining eq "0"} { - lappend headerspans 1 - } else { - #"any" or an integer - lappend headerspans 0 - } - } else { - lappend headerspans $defined_span - } - tcl::dict::set colspans_by_header $h $headerspans - } - } - return $colspans_by_header - } - - #e.g - # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 any 1} 3 {any 0 0 1} - #convert to - # 0 {4 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} - method header_colspans_numeric {} { - set hcolspans [my header_colspans] - if {![tcl::dict::size $hcolspans]} { - return - } - set numcols [llength [tcl::dict::get $hcolspans 0]] ;#assert: all are the same - tcl::dict::for {h spans} $hcolspans { - set c 0 ;#column index - foreach s $spans { - if {$s eq "any"} { - set spanlen 1 - for {set i [expr {$c+1}]} {$i < $numcols} {incr i} { - #next 'any' or non-zero ends an 'any' span - if {[lindex $spans $i] ne "0"} { - break - } - incr spanlen - } - #overwrite the 'any' with it's actual span - set modified_spans [dict get $hcolspans $h] - lset modified_spans $c $spanlen - dict set hcolspans $h $modified_spans - } - incr c - } - } - return $hcolspans - } - - #should be configure_headerrow ? - method configure_header {index_expression args} { - #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. - #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis - #e.g o_headerstates: 0 {maxheightseen 1} 1 {maxheightseen 2} - set num_headers [my header_count_calc] - set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression] - if {$hidx eq ""} { - error "textblock::table::configure_header - no row defined at index '$hidx'." - } - if {$hidx > $num_headers -1} { - #assert - shouldn't happen - error "textblock::table::configure_header error headerstates data is out of sync" - } - - if {![llength $args]} { - set colspans_by_header [my header_colspans] - set result [tcl::dict::create] - tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] - set header_row_items [list] - tcl::dict::for {cidx cdef} $o_columndefs { - set colheaders [tcl::dict::get $cdef -headers] - set relevant_header [lindex $colheaders $hidx] - #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. - } - tcl::dict::set result -values $header_row_items - return $result - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [tcl::dict::keys $o_opts_header_defaults]} { - #query single option - set k [lindex $args 0] - #set val [tcl::dict::get $o_rowdefs $ridx $k] - - set infodict [tcl::dict::create] - #todo - # -blockalignments and -textalignments lists - # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} - #if there is a value it overrides alignments specified on the column - switch -- $k { - -values { - set header_row_items [list] - tcl::dict::for {cidx cdef} $o_columndefs { - set colheaders [tcl::dict::get $cdef -headers] - set relevant_header [lindex $colheaders $hidx] - #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. - - } - set val $header_row_items - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - } - -colspans { - set colspans_by_header [my header_colspans] - set result [tcl::dict::create] - set val [tcl::dict::get $colspans_by_header $hidx] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - } - -ansibase { - set val ??? - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_header_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_header_defaults]" - } - foreach {k v} $args { - if {$k ni [tcl::dict::keys $o_opts_header_defaults]} { - error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_header_defaults]" - } - } - - set checked_opts [list] - #safe jumptable test - #dict for {k v} $args {} - foreach {k v} $args { - switch -- $k { - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set header_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend header_ansibase_items $code - } - } - set header_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] - error "sorry - -ansibase not yet implemented for header rows" - lappend checked_opts $k $header_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - lappend checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -values { - if {[llength $v] > [tcl::dict::size $o_columndefs]} { - error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" - } - lappend checked_opts $k $v - } - -colspans { - set numcols [tcl::dict::size $o_columndefs] - if {[llength $v] > $numcols} { - error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" - } - if {[llength $v] < $numcols} { - puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." - puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" - } - if {[llength $v]} { - set firstspan [lindex $v 0] - set first_is_ok 0 - if {$firstspan eq "any"} { - set first_is_ok 1 - } elseif {[tcl::string::is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} { - set first_is_ok 1 - } - if {!$first_is_ok} { - error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" - } - #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) - set remaining $firstspan - if {$remaining ne "any"} { - incr remaining -1 - } - set spanview $v - set sidx 1 - #because we allow 'any' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'any' first - foreach span [lrange $v 1 end] { - if {$remaining eq "any"} { - if {$span eq "any"} { - set remaining "any" - } elseif {$span > 0} { - #ok to reset to higher val immediately or after an any and any number of following zeros - if {$span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" - } - set remaining $span - incr remaining -1 - } else { - #zero following an any - leave remaining as any - } - } else { - if {$span eq "0"} { - if {$remaining eq "0"} { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" - } else { - incr remaining -1 - } - } else { - if {$remaining eq "0"} { - #ok for new span value of any or > 0 - if {$span ne "any" && $span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" - } - set remaining $span - if {$remaining ne "any"} { - incr remaining -1 - } - } else { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" - } - } - } - incr sidx - } - } - #empty -colspans list should be ok - - #error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now" - lappend checked_opts $k $v - } - default { - lappend checked_opts $k $v - } - } - } - - #configured opts all good - #safe jumptable test - #dict for {k v} $checked_opts {} - #foreach {k v} $checked_opts {} - tcl::dict::for {k v} $checked_opts { - switch -- $k { - -values { - set c 0 - foreach hval $v { - #retrieve -headers from relevant col, insert at header index, and write back. - set thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers] - set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}] - if {$missing > 0} { - lappend thiscol_headers_vertical {*}[lrepeat $missing ""] - } - lset thiscol_headers_vertical $hidx $hval - tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical - #invalidate column width cache - set o_calculated_column_widths [list] - # -- -- -- -- -- -- - #also update maxwidthseen & maxheightseen - set i 0 - set maxwidthseen 0 - #set maxheightseen 0 - foreach hdr $thiscol_headers_vertical { - lassign [textblock::size $hdr] _w this_header_width _h this_header_height - set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0] - if {$this_header_height >= $maxheightseen} { - tcl::dict::set o_headerstates $i maxheightseen $this_header_height - } else { - tcl::dict::set o_headerstates $i maxheightseen $maxheightseen - } - if {$this_header_width >= $maxwidthseen} { - set maxwidthseen $this_header_width - } - incr i - } - tcl::dict::set o_columnstates $c maxwidthheaderseen $maxwidthseen - # -- -- -- -- -- -- - incr c - } - } - -colspans { - #sequence has been verified above - we need to split it and store across columns - set c 0 ;#column index - foreach span $v { - set colspans [tcl::dict::get $o_columndefs $c -header_colspans] - if {$hidx > [llength $colspans]-1} { - set colspans_by_header [my header_colspans] - #puts ">>>>>?$colspans_by_header" - #we are allowed to lset only one beyond the current length to append - #but there may be even less or no entries present in a column - # - the ability to underspecify and calculate the missing values makes setting the values complicated. - #use the header_colspans calculation to update only those entries necessary - set spanlist [list] - for {set h 0} {$h < $hidx} {incr h} { - set cspans [tcl::dict::get $colspans_by_header $h] - set requiredval [lindex $cspans $c] - lappend spanlist $requiredval - } - tcl::dict::set o_columndefs $c -header_colspans $spanlist - - set colspans [tcl::dict::get $o_columndefs $c -header_colspans] - } - - lset colspans $hidx $span - tcl::dict::set o_columndefs $c -header_colspans $colspans - incr c - } - } - } - } - } - - method add_row {valuelist args} { - #*** !doctools - #[call class::table [method add_row] [arg args]] - if {[tcl::dict::size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [tcl::dict::size $o_columndefs])} { - set msg "" - append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [tcl::dict::size $o_columndefs]" \n - append msg "rowdata: $valuelist" - error $msg - } - if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { - error "add_row - no values supplied, and no columns defined, so cannot use default column values" - } - - set defaults [tcl::dict::create\ - -minheight 1\ - -maxheight ""\ - -ansibase ""\ - -ansireset "\uFFEF"\ - ] - set o_opts_row_defaults $defaults - - if {[llength $args] %2 !=0} { - error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" - } - #safe jumptable test - #dict for {k v} $args {} - foreach {k v} $args { - switch -- $k { - -minheight - -maxheight - -ansibase - -ansireset {} - default { - error "Invalid option '$k' Known options: [tcl::dict::keys $defaults] (-ansireset is read-only)" - } - } - } - set opts [tcl::dict::merge $defaults $args] - - set auto_columns 0 - if {[tcl::dict::size $o_columndefs] == 0} { - set auto_columns 1 - #no columns defined - auto define with defaults for each column in first supplied row - #auto define columns only valid if no existing columns - #the autocolumns must be added before configure_row - but if configure_row fails - we need to remove them! - foreach el $valuelist { - my add_column - } - } else { - if {![llength $valuelist]} { - tcl::dict::for {k coldef} $o_columndefs { - lappend valuelist [tcl::dict::get $coldef -defaultvalue] - } - } - } - set rowcount [tcl::dict::size $o_rowdefs] - tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure - - if {[catch { - my configure_row $rowcount {*}$opts - } errMsg]} { - #undo anything we saved before configure_row - tcl::dict::unset o_rowdefs $rowcount - #remove auto_columns - if {$auto_columns} { - set o_columndata [tcl::dict::create] - set o_columndefs [tcl::dict::create] - set o_columnstate [tcl::dict::create] - } - error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" - } - - - set c 0 - set max_height_seen 1 - foreach v $valuelist { - set prev_maxwidth [tcl::dict::get $o_columnstates $c maxwidthbodyseen] - set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] - - tcl::dict::lappend o_columndata $c $v - set valheight [textblock::height $v] - if {$valheight > $max_height_seen} { - set max_height_seen $valheight - } - set width [textblock::width $v] - if {$width > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { - tcl::dict::set o_columnstates $c maxwidthbodyseen $width - } - if {$width < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { - tcl::dict::set o_columnstates $c minwidthbodyseen $width - } - - if {[tcl::dict::get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [tcl::dict::get $o_columnstates $c minwidthbodyseen] < $prev_minwidth} { - #invalidate calculated column width cache if any new value was outside the previous range of widths - set o_calculated_column_widths [list] - } - incr c - } - - set opt_maxh [tcl::dict::get $o_rowdefs $rowcount -maxheight] - if {$opt_maxh ne ""} { - tcl::dict::set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}] - } else { - tcl::dict::set o_rowstates $rowcount -maxheight $max_height_seen - } - - return $rowcount - } - method configure_row {index_expression args} { - set ridx [lindex [tcl::dict::keys $o_rowdefs] $index_expression] - if {$ridx eq ""} { - error "textblock::table::configure_row - no row defined at index '$ridx'.Use add_row to define rows" - } - if {![llength $args]} { - return [tcl::dict::get $o_rowdefs $ridx] - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [tcl::dict::keys $o_opts_row_defaults]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_rowdefs $ridx $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_row_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_row_defaults]" - } - foreach {k v} $args { - if {$k ni [tcl::dict::keys $o_opts_row_defaults]} { - error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_row_defaults]" - } - } - set checked_opts [list] - foreach {k v} $args { - switch -- $k { - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set row_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend row_ansibase_items $code - } - } - set row_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] - lappend checked_opts $k $row_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - lappend checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_row -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - default { - lappend checked_opts $k $v - } - } - } - - set current_opts [tcl::dict::get $o_rowdefs $ridx] - set opts [tcl::dict::merge $current_opts $checked_opts] - - #check minheight and maxheight together - set opt_minh [tcl::dict::get $opts -minheight] - set opt_maxh [tcl::dict::get $opts -maxheight] - - #todo - allow zero values to hide/collapse rows as is possible with columns - if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { - error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" - } - if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { - error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" - } - if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { - error "[tcl::namespace::current]::table::configure_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" - } - tcl::dict::set o_rowstates $ridx -minheight $opt_minh - - - tcl::dict::set o_rowdefs $ridx $opts - } - method row_count {} { - return [tcl::dict::size $o_rowdefs] - } - method row_clear {} { - set o_rowdefs [tcl::dict::create] - set o_rowstates [tcl::dict::create] - #The data values are stored by column regardless of whether added row by row - tcl::dict::for {cidx records} $o_columndata { - tcl::dict::set o_columndata $cidx [list] - #reset only the body fields in o_columnstates - tcl::dict::set o_columnstates $cidx minwidthbodyseen 0 - tcl::dict::set o_columnstates $cidx maxwidthbodyseen 0 - } - set o_calculated_column_widths [list] - } - method clear {} { - my row_clear - set o_columndefs [tcl::dict::create] - set o_columndata [tcl::dict::create] - set o_columnstates [tcl::dict::create] - } - - - - #method Get_columns_by_name {namematch_list} { - #} - - #specify range with x..y - method Get_columns_by_indices {index_list} { - foreach spec $index_list { - if {[tcl::string::is integer -strict $c]} { - set colidx $c - } else { - tcl::dict::for {colidx coldef} $o_columndefs { - #if {[tcl::string::match x x]} {} - } - } - } - } - method Get_boxlimits_and_joins {position fname_body} { - #fname_body will be "custom" or one of the predefined types light,heavy etc - switch -- $position { - left { - return [tcl::dict::create \ - boxlimits [list hlb blc vll]\ - boxlimits_top [list hlb blc vll hlt tlc]\ - joins [list down]\ - bodyjoins [list down-$fname_body]\ - ] - } - inner { - return [tcl::dict::create \ - boxlimits [list hlb blc vll]\ - boxlimits_top [list hlb blc vll hlt tlc]\ - joins [list down left]\ - bodyjoins [list left down-$fname_body] - ] - } - right { - return [tcl::dict::create \ - boxlimits [list hlb blc vll vlr brc]\ - boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ - joins [list down left]\ - bodyjoins [list left down-$fname_body]\ - ] - } - solo { - return [tcl::dict::create \ - boxlimits [list hlb blc vll vlr brc]\ - boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ - joins [list down]\ - bodyjoins [list down-$fname_body]\ - ] - } - default { - error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo" - } - } - } - method Get_boxlimits_and_joins1 {position fname_body} { - #fname_body will be "custom" or one of the predefined types light,heavy etc - switch -- $position { - left { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list down-$fname_body] - set boxlimits_position [list hlb blc vll] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set boxlimits_toprow [list hlb blc vll hlt tlc] - set joins [list down] - } - inner { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list left down-$fname_body] - set boxlimits_position [list hlb blc vll] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set boxlimits_toprow [list hlb blc vll hlt tlc] - set joins [list down left] - } - right { - #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} - set header_body_joins [list left down-$fname_body] - set boxlimits_position [list hlb blc vll vlr brc] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] - set joins [list down left] - } - solo { - #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} - set header_body_joins [list down-$fname_body] - set boxlimits_position [list hlb blc vll vlr brc] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] - set joins [list down] - } - } - return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ] - } - method get_column_by_index {index_expression args} { - #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" - #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. - set opts [tcl::dict::create\ - -position "inner"\ - -return "string"\ - ] - foreach {k v} $args { - switch -- $k { - -position - -return { - tcl::dict::set opts $k $v - } - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid option '$k'. Known options [tcl::dict::keys $opts]" - } - } - } - set opt_posn [tcl::dict::get $opts -position] - set opt_return [tcl::dict::get $opts -return] - - switch -- $opt_posn { - left - inner - right - solo {} - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo]" - } - } - switch -- $opt_return { - string - dict {} - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_return' for -return. Valid values: string dict" - } - } - - set columninfo [my get_column_cells_by_index $index_expression] - set header_list [tcl::dict::get $columninfo headers] - #puts "===== header_list: $header_list" - set cells [tcl::dict::get $columninfo cells] - - set topt_show_header [tcl::dict::get $o_opts_table -show_header] - if {$topt_show_header eq ""} { - set allheaders 0 - set all_cols [tcl::dict::keys $o_columndefs] - foreach c $all_cols { - incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] - } - if {$allheaders == 0} { - set do_show_header 0 - } else { - set do_show_header 1 - } - } else { - set do_show_header $topt_show_header - } - set topt_show_footer [tcl::dict::get $o_opts_table -show_footer] - - - set output "" - set part_header "" - set part_body "" - set part_footer "" - - set boxlimits "" - set joins "" - set header_boxlimits [list] - set header_body_joins [list] - - - set ftypes [my Get_frametypes] - set ftype_body [tcl::dict::get $ftypes body] - if {[llength $ftype_body] >= 2} { - set fname_body "custom" - } else { - set fname_body $ftype_body - } - set ftype_header [tcl::dict::get $ftypes header] - if {[llength $ftype_header] >= 2} { - set fname_header "custom" - } else { - set fname_header $ftype_header - } - - set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] - set header_body_joins [tcl::dict::get $limj bodyjoins] - set joins [tcl::dict::get $limj joins] - set boxlimits_position [tcl::dict::get $limj boxlimits] - set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] - #use struct::set instead of simple for loop - will be faster at least when critcl available - set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] - set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] - set header_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_position] - set header_boxlimits_toprow [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_toprow] - - set fmap [tcl::dict::get $o_opts_table_effective -framemap_body] - set hmap [tcl::dict::get $o_opts_table_effective -framemap_header] - - #if {![tcl::dict::get $o_opts_table -show_edge]} { - # set body_edgemap [textblock::class::table_edge_map ""] - # dict for {k v} $fmap { - # #tcl::dict::set fmap $k [tcl::dict::merge $v [tcl::dict::get $body_edgemap $k]] - # } - # set header_edgemap [textblock::class::header_edge_map ""] - # dict for {k v} $hmap { - # #tcl::dict::set hmap $k [tcl::dict::merge $v [tcl::dict::get $header_edgemap $k]] - # } - #} - set sep_elements_horizontal $::textblock::class::table_hseps - set sep_elements_vertical $::textblock::class::table_vseps - - set topmap [tcl::dict::get $fmap top$opt_posn] - set botmap [tcl::dict::get $fmap bottom$opt_posn] - set midmap [tcl::dict::get $fmap middle$opt_posn] - set onlymap [tcl::dict::get $fmap only$opt_posn] - - set hdrmap [tcl::dict::get $hmap only${opt_posn}] - - set topseps_h [tcl::dict::get $sep_elements_horizontal top$opt_posn] - set midseps_h [tcl::dict::get $sep_elements_horizontal middle$opt_posn] - set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] - set midseps_v [tcl::dict::get $sep_elements_vertical middle$opt_posn] - set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] - set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] - - #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway - set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] - - lassign [my Get_seps] _h show_seps_h _v show_seps_v - set return_headerheight 0 - set return_headerwidth 0 - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - - set colwidth [my column_width $cidx] - - set col_blockalign [tcl::dict::get $o_columndefs $cidx -blockalign] - - if {$do_show_header} { - #puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap" - set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure - set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] - if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { - set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] - set ansiborder_final $ansibase_header$ansiborder_header$extrabg - } else { - set ansiborder_final $ansibase_header$ansiborder_header - } - set RST [punk::ansi::a] - - - set hcolwidth $colwidth - #set hcolwidth [my column_width_configured $cidx] - set hcell_line_blank [tcl::string::repeat " " $hcolwidth] - - set all_colspans [my header_colspans_numeric] - - #put our framedef calls together - set fdef_header [textblock::framedef $ftype_header] - set framedef_leftbox [textblock::framedef -joins left $ftype_header] - set framedef_headerdown_same [textblock::framedef -joins {down} $ftype_header] - set framedef_headerdown_body [textblock::framedef -joins [list down-$fname_body] $ftype_header] - #default span_extend_map - used as base to customise with specific joins - set span_extend_map [tcl::dict::create \ - vll " "\ - tlc [tcl::dict::get $fdef_header hlt]\ - blc [tcl::dict::get $fdef_header hlb]\ - ] - - - #used for colspan-zero header frames - set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test - - set hrow 0 - set hmax [expr {[llength $header_list] -1}] - foreach header $header_list { - set headerspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerspans $cidx] - set hval $ansibase_header$header ;#no reset - set rowh [my header_height $hrow] - - if {$hrow == 0} { - set hlims $header_boxlimits_toprow - set rowpos "top" - if {$hrow == $hmax} { - set rowpos "only" - } - } else { - set hlims $header_boxlimits - set rowpos "middle" - if {$hrow == $hmax} { - set rowpos "bottom" - } - } - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {$hrow == $hmax} { - set header_joins $header_body_joins - } else { - set header_joins $joins - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] - } - #puts ">>> headerspans: $headerspans cidx: $cidx" - - #if {$this_span eq "any" || $this_span > 0} {} - #changed to processing only numeric colspans - - if {$this_span > 0} { - set startmap [tcl::dict::get $hmap $rowpos${opt_posn}] - #look at spans in header below to determine joins required at blc - if {$show_seps_v} { - if {[tcl::dict::exists $all_colspans [expr {$hrow+1}]]} { - set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] - set spanbelow [lindex $next_spanlist $cidx] - if {$spanbelow == 0} { - #we don't want a down-join for blc - use a framedef with only left joins - tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] - } - } else { - set next_spanlist [list] - } - } - - #supporting wrapping in headers might be a step too difficult for little payoff. - #we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib) - #The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex. - #May be better to require user to pre-wrap as needed - ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] - - #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used - #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) - - # -width is always +2 - as the boxlimits take into account show_vseps and show_edge - #set header_cell_startspan [textblock::frame -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - # -ansibase $ansibase_header -ansiborder $ansiborder_final\ - # -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\ - # ] - - if {$this_span == 1} { - #write the actual value now - set cellcontents $hval - } else { - #just write an empty vertical placeholder. The spanned value will be overtyped below - set cellcontents [::join [lrepeat [llength [split $hval \n]] ""] \n] - } - set header_cell_startspan [textblock::frame -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ - ] - - if {$this_span != 1} { - #puts "===>\n$header_cell_startspan\n<===" - set spanned_parts [list $header_cell_startspan] - #assert this_span == "any" or >1 ie a header that spans other columns - #therefore more parts to append - #set remaining_cols [lrange [tcl::dict::keys $o_columndefs] $cidx end] - set remaining_spans [lrange $headerspans $cidx+1 end] - set spanval [join $remaining_spans ""] ;#so we can test for all zeros - set spans_to_rhs 0 - if {[expr {$spanval}] == 0} { - #puts stderr "SPANS TO RHS" - set spans_to_rhs 1 - } - - #puts ">> remaining_spans: $remaining_spans" - set spancol [expr {$cidx + 1}] - set h_lines [lrepeat $rowh ""] - set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow - - - - set last [expr {[llength $remaining_spans] -1}] - set i 0 - foreach s $remaining_spans { - if {$s == 0} { - if {$i == $last} { - set next_posn right - #set next_posn inner - } else { - set next_posn inner - } - - set next_headerseps_v [tcl::dict::get $sep_elements_vertical top$next_posn] ;#static top ok - - set limj [my Get_boxlimits_and_joins $next_posn $fname_body] - set span_joins_body [tcl::dict::get $limj bodyjoins] - set span_joins [tcl::dict::get $limj joins] - set span_boxlimits [tcl::dict::get $limj boxlimits] - set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] - #use struct::set instead of simple for loop - will be faster at least when critcl available - #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] - #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] - set header_span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits] - set header_span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits_top] - if {$hrow == 0} { - set hlims $header_span_boxlimits_top - } else { - set hlims $header_span_boxlimits - } - - set this_span_map $span_extend_map - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $next_headerseps_v] - } else { - if {[llength $next_spanlist]} { - set spanbelow [lindex $next_spanlist $spancol] - if {$spanbelow != 0} { - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype - } - } else { - #join to body - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype - } - } - - if {$hrow == $hmax} { - set header_joins $span_joins_body - } else { - set header_joins $span_joins - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] - } - - set contentwidth [my column_width $spancol] - set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\ - ] - lappend spanned_parts $header_cell - } else { - break - } - incr spancol - incr i - } - - #JMN - #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic - set spanned_frame [textblock::join_basic -- {*}$spanned_parts] - - if {$spans_to_rhs} { - if {$cidx == 0} { - set fake_posn solo - } else { - set fake_posn right - } - set x_limj [my Get_boxlimits_and_joins $fake_posn $fname_body] - if {$hrow == 0} { - set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] - set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] - } else { - set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] - set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] - } - } else { - if {$hrow == 0} { - set hlims $header_boxlimits_toprow - } else { - set hlims $header_boxlimits - } - } - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - if {$spans_to_rhs} { - #assert fake_posn has been set above based on cidx and spans_to_rhs - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts ${rowpos}$fake_posn] ] - } else { - #use the edge_parts corresponding to the column being written to ie use opt_posn - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] - } - } - - set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements - #set spacemap [list hl * vl * tlc * blc * trc * brc *] - #-usecache 1 ok - #hval is not raw headerval - it has been padded to required width and has ansi applied - set hblock [textblock::frame -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase - #puts "==>boxlimits:'$hlims' hval_width:[tcl::string::length $hval] blockwidth:[textblock::width $hblock]" - #puts $hblock - #puts "==>hval:'$hval'[a]" - #puts "==>hval:'[ansistring VIEW $hval]'" - #set spanned_frame [overtype::renderspace -transparent 1 $spanned_frame $hblock] - - #spanned values default left - todo make configurable - - #TODO - #consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span - #we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes? - #this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span. - #(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned) - - set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] - #POTENTIAL BUG (fixed with spans_to_rhs above) - #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) - #we need to shift 1 to the left when doing our overtype with blockalign right - #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge - #(even though the column position may be left or inner) - - - - } else { - #this_span == 1 - set spanned_frame [textblock::join_basic -- $header_cell_startspan] - } - - - append part_header $spanned_frame - append part_header \n - } else { - #zero span header directly in this column ie one that is being colspanned by some column to our left - #previous col will already have built lines for this in it's own header rhs overhang - #we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent. - - #set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1] - - #if there are no header elements above then we will need a minimum of the column width - #may be extended to the widest portion of the header in the loop below - set padwidth [my column_width $cidx] - - - #under assumption we are building table using L frame method and that horizontal borders are only ever 1 high - # - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc - #avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 ) - if 0 { - #breaks -show_edge 0 - if {$rowpos eq "top" && [tcl::dict::get $o_opts_table -show_edge]} { - set padheight [expr {$rowh + 2}] - } else { - set padheight [expr {$rowh + 1}] - } - set bline [tcl::string::repeat $TSUB [expr {$padwidth +1}]] - set h_lines [lrepeat $padheight $bline] - set hcell_blank [::join $h_lines \n] - set header_frame $hcell_blank - } else { - set bline [tcl::string::repeat $TSUB $padwidth] - set h_lines [lrepeat $rowh $bline] - set hcell_blank [::join $h_lines \n] - # -usecache 1 ok - #frame borders will never display - so use the simplest frametype and don't apply any ansi - #puts "===>zerospan hlims: $hlims" - set header_frame [textblock::frame -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ - -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ - ] - } - - append part_header $header_frame\n - - } - incr hrow - } - if {![llength $header_list]} { - #no headers - but we've been asked to show_header - #display a zero content-height header (ie outline if edge is being shown - or bottom bar) - set hlims $header_boxlimits_toprow - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts only$opt_posn] ] - } - set header_joins $header_body_joins - set header_frame [textblock::frame -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $hdrmap -joins $header_joins\ - ] - append part_header $header_frame\n - } - set part_header [tcl::string::trimright $part_header \n] - lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight - - set padline [tcl::string::repeat $TSUB $return_headerwidth] - set adjusted_lines [list] - foreach ln [split $part_header \n] { - if {[tcl::string::first $TSUB $ln] >=0} { - lappend adjusted_lines $padline - } else { - lappend adjusted_lines $ln - } - } - set part_header [::join $adjusted_lines \n] - #append output $part_header \n - } - - set r 0 - set rmax [expr {[llength $cells]-1}] - - - set blims_mid $boxlimits - set blims_top $boxlimits - set blims_bot $boxlimits - set blims_top_headerless $boxlimits_headerless - set blims_only $boxlimits - set blims_only_headerless $boxlimits_headerless - if {!$show_seps_h} { - set blims_mid [struct::set difference $blims_mid $midseps_h] - set blims_top [struct::set difference $blims_top $topseps_h] - set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_h] - } - if {!$show_seps_v} { - set blims_mid [struct::set difference $blims_mid $midseps_v] - set blims_top [struct::set difference $blims_top $topseps_v] - set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_v] - set blims_bot [struct::set difference $blims_bot $botseps_v] - set blims_only [struct::set difference $blims_only $onlyseps_v] - set blims_only_headerless [struct::set difference $blims_only_headerless $onlyseps_v] - } - - set colidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range - - set opt_col_ansibase [tcl::dict::get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column - #set colwidth [my column_width $colidx] - - set body_ansibase [tcl::dict::get $o_opts_table -ansibase_body] - #set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body - set body_ansiborder [tcl::dict::get $o_opts_table -ansiborder_body] - if {[tcl::dict::get $o_opts_table -frametype] eq "block"} { - #block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled - #we need to only accept background ansi codes from the columndef ansibase for this - set col_bg [punk::ansi::codetype::sgr_merge_singles [list $opt_col_ansibase] -filter_fg 1] ;#special merge for block borders - don't override fg colours - set border_ansi $body_ansibase$body_ansiborder$col_bg - } else { - set border_ansi $body_ansibase$body_ansiborder - } - - - set r 0 - set ftblock [expr {[tcl::dict::get $o_opts_table -frametype] eq "block"}] - foreach c $cells { - #cells in column - each new c is in a different row - set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - set row_bg "" - if {$row_ansibase ne ""} { - set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] - } - - set ansibase $body_ansibase$opt_col_ansibase - #todo - joinleft,joinright,joindown based on opts in args - set cell_ansibase "" - - set ansiborder_body_col_row $border_ansi$row_bg - set ansiborder_final $ansiborder_body_col_row - #$c will always have ansi resets due to overtype behaviour ? - #todo - review overtype - if {[punk::ansi::ta::detect $c]} { - #use only the last ansi sequence in the cell value - #Filter out foreground and use background for ansiborder override - set parts [punk::ansi::ta::split_codes_single $c] - #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt - set codes [list] - foreach {pt cd} $parts { - if {$cd ne ""} { - lappend codes $cd - } - } - #set takebg [lindex $parts end-1] - #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] - set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] - #puts --->[ansistring VIEW $codes] - - if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { - if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { - #special case double reset at end of content - set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters - set ansibase "" - set row_ansibase "" - if {$ftblock} { - set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1] - } - set cell_ansibase $cell_ansi_tail - } else { - #single trailing reset in content - set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase - } - } else { - if {$ftblock} { - #no resets - use cell's bg to extend to the border - only for block frames - set ansiborder_final $ansiborder_body_col_row$cell_bg - } - set cell_ansibase $cell_bg - } - } - - set ansibase_final $ansibase$row_ansibase$cell_ansibase - - if {$r == 0} { - if {$r == $rmax} { - set joins [lremove $joins [lsearch $joins down*]] - set bmap $onlymap - if {$do_show_header} { - set blims $blims_only - } else { - set blims $blims_only_headerless - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] - } - } else { - set bmap $topmap - if {$do_show_header} { - set blims $blims_top - } else { - set blims $blims_top_headerless - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] - } - } - set rowframe [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] - set return_bodywidth [textblock::widthtopline $rowframe] ;#frame lines always same width - just look at top line - append part_body $rowframe \n - } else { - if {$r == $rmax} { - set joins [lremove $joins [lsearch $joins down*]] - set bmap $botmap - set blims $blims_bot - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts bottom$opt_posn] ] - } - } else { - set bmap $midmap - set blims $blims_mid ;#will only be reduced from boxlimits if -show_seps was processed above - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] - } - } - append part_body [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n - } - incr r - } - #return empty (zero content height) row if no rows - if {![llength $cells]} { - set joins [lremove $joins [lsearch $joins down*]] - #we need to know the width of the column to setup the empty cell properly - #even if no header displayed - we should take account of any defined column widths - set colwidth [my column_width $index_expression] - - if {$do_show_header} { - set blims $blims_only - } else { - append part_body \n - set blims $blims_only_headerless - } - #note that if show_edge is 0 - then for this empty line - we will not expect to see any bars - #This is because the frame with no data had vertical components made entirely of corner elements - #we could just append a newline when -show_edge is zero, but we want the correct width even when empty - for proper column joins when there are colspanned headers. - # - if {![tcl::dict::get $o_opts_table -show_edge]} { - #set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] - #append output [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n - append part_body [tcl::string::repeat " " $colwidth] \n - set return_bodywidth $colwidth - } else { - set emptyframe [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] - append part_body $emptyframe \n - set return_bodywidth [textblock::width $emptyframe] - } - } - #assert bodywidth is integer >=0 whether there are rows or not - - #trim only 1 newline - if {[tcl::string::index $part_body end] eq "\n"} { - set part_body [tcl::string::range $part_body 0 end-1] - } - set return_bodyheight [textblock::height $part_body] - #append output $part_body - - if {$opt_return eq "string"} { - if {$part_header ne ""} { - set output $part_header - if {$part_body ne ""} { - append output \n $part_body - } - } else { - set output $part_body - } - return $output - } else { - return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] - } - } - - method get_column_cells_by_index {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - set range "" - if {[tcl::dict::size $o_columndefs] > 0} { - set range "0..[expr {[tcl::dict::size $o_columndefs] -1}]" - } else { - set range empty - } - error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" - } - #assert cidx is integer >=0 - set num_header_rows [my header_count] - set cdef [tcl::dict::get $o_columndefs $cidx] - set headerlist [tcl::dict::get $cdef -headers] - set ansibase_col [tcl::dict::get $cdef -ansibase] - set textalign [tcl::dict::get $cdef -textalign] - switch -- $textalign { - left {set pad right} - right {set pad left} - default { - set pad "centre" ;#todo? - } - } - - set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] - set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] - - #set header_underlay $ansibase_header$cell_line_blank - - #set hdrwidth [my column_width_configured $cidx] - #set all_colspans [my header_colspans] - #we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric - set all_colspans [my header_colspans_numeric] - #JMN - #store configured widths so we don't look up for each header line - #set configured_widths [list] - #foreach c [tcl::dict::keys $o_columndefs] { - # #lappend configured_widths [my column_width $c] - # #we don't just want the width of the column in the body - or the headers will get truncated - # lappend configured_widths [my column_width_configured $c] - #} - - set output [tcl::dict::create] - tcl::dict::set output headers [list] - - set showing_vseps [my Showing_vseps] - for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} { - set hdr [lindex $headerlist $hrow] - set header_maxdataheight [my header_height $hrow] ;#from cached headerstates - set headerrow_colspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerrow_colspans $cidx] - - #set this_hdrwidth [lindex $configured_widths $cidx] - set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign - - set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] - set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] - set hval_lines [split $hdr \n] - set hval_lines [concat $hval_lines $hcell_lines] - set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top - set hval_block [::join $hval_lines \n] - set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] - tcl::dict::lappend output headers $hcell - } - - - #set colwidth [my column_width $cidx] - #set cell_line_blank [tcl::string::repeat " " $colwidth] - set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1] - set cell_line_blank [tcl::string::repeat " " $datawidth] - - - - set items [tcl::dict::get $o_columndata $cidx] - #puts "---> columndata $o_columndata" - - #set opt_row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - #set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase - - tcl::dict::set output cells [list];#ensure we return something for cells key if no items in list - set r 0 - foreach cval $items { - #todo move to row_height method ? - set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] - set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] - set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] - if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { - #an exact height is defined for the row - set rowh $rowdefminh - } else { - if {$rowdefminh eq ""} { - if {$rowdefmaxh eq ""} { - #both defs empty - set rowh $maxdataheight - } else { - set rowh [expr {min(1,$rowdefmaxh,$maxdataheight)}] - } - } else { - if {$rowdefmaxh eq ""} { - set rowh [expr {max($rowdefminh,$maxdataheight)}] - } else { - if {$maxdataheight < $rowdefminh} { - set rowh $rowdefminh - } else { - set rowh [expr {max($rowdefminh,$maxdataheight)}] - } - } - } - } - - set cell_lines [lrepeat $rowh $cell_line_blank] - #set cell_blank [join $cell_lines \n] - - - set cval_lines [split $cval \n] - set cval_lines [concat $cval_lines $cell_lines] - set cval_lines [lrange $cval_lines 0 $rowh-1] - set cval_block [::join $cval_lines \n] - - - set cell [textblock::pad $cval_block -width $datawidth -padchar " " -within_ansi 1 -which $pad] - #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] - tcl::dict::lappend output cells $cell - - incr r - } - return $output - } - method get_column_values_by_index {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - return [tcl::dict::get $o_columndata $cidx] - } - method debug {args} { - #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) - set defaults [tcl::dict::create\ - -usetables 1\ - ] - foreach {k v} $args { - switch -- $k { - -usetables {} - default { - error "table debug unrecognised option '$k'. Known options: [tcl::dict::keys $defaults]" - } - } - } - set opts [tcl::dict::merge $defaults $args] - set opt_usetables [tcl::dict::get $opts -usetables] - - puts stdout "rowdefs: $o_rowdefs" - puts stdout "rowstates: $o_rowstates" - #puts stdout "columndefs: $o_columndefs" - puts stdout "columndefs:" - if {!$opt_usetables} { - tcl::dict::for {k v} $o_columndefs { - puts " $k $v" - } - } else { - set t [textblock::class::table new] - $t add_column -headers "Col" - tcl::dict::for {col coldef} $o_columndefs { - foreach property [tcl::dict::keys $coldef] { - if {$property eq "-ansireset"} { - continue - } - $t add_column -headers $property - } - break - } - - #build our inner tables first so we can sync widths - set col_header_tables [tcl::dict::create] - set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths - tcl::dict::for {col coldef} $o_columndefs { - set row [list $col] - set colheaders [tcl::dict::get $coldef -headers] - #inner table probably overkill here ..but just as easy - set htable [textblock::class::table new] - $htable configure -show_header 1 -show_edge 0 -show_hseps 0 - $htable add_column -headers row - $htable add_column -headers text - $htable add_column -headers WxH - $htable add_column -headers span - set hnum 0 - set spans [tcl::dict::get $o_columndefs $col -header_colspans] - foreach h $colheaders s $spans { - lassign [textblock::size $h] _w width _h height - $htable add_row [list "$hnum " $h "${width}x${height}" $s] - incr hnum - } - $htable configure_column 0 -ansibase [a+ web-dimgray] - tcl::dict::set col_header_tables $col $htable - set colwidths [$htable column_widths] - set icol 0 - foreach w $colwidths { - if {$w > [tcl::dict::get $max_widths $icol]} { - tcl::dict::set max_widths $icol $w - } - incr icol - } - } - - #safe jumptable test - #dict for {col coldef} $o_columndefs {} - tcl::dict::for {col coldef} $o_columndefs { - set row [list $col] - #safe jumptable test - #dict for {property val} $coldef {} - tcl::dict::for {property val} $coldef { - switch -- $property { - -ansireset {continue} - -headers { - set htable [tcl::dict::get $col_header_tables $col] - tcl::dict::for {innercol maxw} $max_widths { - $htable configure_column $innercol -minwidth $maxw -blockalign left - } - lappend row [$htable print] - $htable destroy - } - default { - lappend row $val - } - } - } - $t add_row $row - } - - - - - $t configure -show_header 1 - puts stdout [$t print] - $t destroy - } - puts stdout "columnstates: $o_columnstates" - puts stdout "headerstates: $o_headerstates" - tcl::dict::for {k coldef} $o_columndefs { - if {[tcl::dict::exists $o_columndata $k]} { - set headerlist [tcl::dict::get $coldef -headers] - set coldata [tcl::dict::get $o_columndata $k] - set colinfo "rowcount: [llength $coldata]" - set allfields [concat $headerlist $coldata] - if {[llength $allfields]} { - set widest [tcl::mathfunc::max {*}[lmap v $allfields {textblock::width $v}]] - } else { - set widest 0 - } - append colinfo " widest of headers and data: $widest" - } else { - set colinfo "WARNING - no columndata record for column key '$k'" - } - puts stdout "column $k columndata info: $colinfo" - } - set result "" - set cols [list] - set max [expr {[tcl::dict::size $o_columndefs]-1}] - foreach c [tcl::dict::keys $o_columndefs] { - if {$c == 0} { - lappend cols [my get_column_by_index $c -position left] " " - } elseif {$c == $max} { - lappend cols [my get_column_by_index $c -position right] - } else { - lappend cols [my get_column_by_index $c -position inner] " " - } - } - append result [textblock::join -- {*}$cols] - return $result - } - #column width including headers - but without colspan consideration - method column_width_configured {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - #assert cidx is now >=0 integer within the range of defined columns - set cdef [tcl::dict::get $o_columndefs $cidx] - set defminw [tcl::dict::get $cdef -minwidth] - set defmaxw [tcl::dict::get $cdef -maxwidth] - if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { - #an exact width is defined for the column - no need to look at data width - set colwidth $defminw - } else { - #set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1] - set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - #set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1] - #set hwidest_singlespan ?? - set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - set widest [expr {max($hwidest,$bwidest)}] - #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. - #if so - a truncated line shouldn't be included in our width calculation - if {$defminw eq ""} { - if {$defmaxw eq ""} { - set colwidth $widest - } else { - set colwidth [expr {min($defmaxw,$widest)}] - } - } else { - if {$defmaxw eq ""} { - set colwidth [expr {max($defminw,$widest)}] - } else { - if {$widest < $defminw} { - set colwidth $defminw - } else { - if {$widest > $defmaxw} { - set colwidth $defmaxw - } else { - set colwidth [expr {max($defminw,$widest)}] - } - } - } - } - } - return $colwidth - } - - method column_width {index_expression} { - if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { - my calculate_column_widths -algorithm $o_column_width_algorithm - } - return [lindex $o_calculated_column_widths $index_expression] - } - method column_widths {} { - if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { - my calculate_column_widths -algorithm $o_column_width_algorithm - } - return $o_calculated_column_widths - } - - #width of a table includes borders and seps - #whereas width of a column refers to the borderless width (inner width) - method width {} { - #calculate width based on assumption frame verticals are 1-wide - review - what about custom unicode double-wide frame? - set colwidths [my column_widths] - set contentwidth [tcl::mathop::+ {*}$colwidths] - set twidth $contentwidth - if {[my Showing_vseps]} { - incr twidth [llength $colwidths] - incr twidth -1 - } - if {[tcl::dict::get $o_opts_table -show_edge]} { - incr twidth 2 - } - return $twidth - } - - #column *body* content width - method basic_column_width {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - #puts "===column_width $index_expression" - #assert cidx is now >=0 integer within the range of defined columns - set cdef [tcl::dict::get $o_columndefs $cidx] - set defminw [tcl::dict::get $cdef -minwidth] - set defmaxw [tcl::dict::get $cdef -maxwidth] - if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { - #an exact width is defined for the column - no need to look at data width - #review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header - set colwidth $defminw - } else { - #set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0] - set widest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. - #if so - a truncated line shouldn't be included in our width calculation - if {$defminw eq ""} { - if {$defmaxw eq ""} { - set colwidth $widest - } else { - set colwidth [expr {min($defmaxw,$widest)}] - } - } else { - if {$defmaxw eq ""} { - set colwidth [expr {max($defminw,$widest)}] - } else { - if {$widest < $defminw} { - set colwidth $defminw - } else { - if {$widest > $defmaxw} { - set colwidth $defmaxw - } else { - set colwidth [expr {max($defminw,$widest)}] - } - } - } - } - } - set configured_widths [list] - foreach c [tcl::dict::keys $o_columndefs] { - lappend configured_widths [my column_width_configured $c] - } - set header_colspans [my header_colspans] - set width_max $colwidth - set test_width $colwidth - set showing_vseps [my Showing_vseps] - set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - tcl::dict::for {h colspans} $header_colspans { - set spanc [lindex $colspans $cidx] - #set headers [tcl::dict::get $cdef -headers] - #set thiscol_widest_header 0 - #if {[llength $headers] > 0} { - # set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]] - #} - if {$spanc eq "1"} { - if {$thiscol_widest_header > $colwidth} { - set test_width [expr {max($thiscol_widest_header,$colwidth)}] - if {$defmaxw ne ""} { - set test_width [expr {min($colwidth,$defmaxw)}] - } - } - set width_max [expr {max($test_width,$width_max)}] - continue - } - if {$spanc eq "any" || $spanc > 1} { - set spanned [list] ;#spanned is other columns spanned - not including this one - set cnext [expr {$cidx +1}] - set spanlength [lindex $colspans $cnext] - while {$spanlength eq "0" && $cnext < [llength $colspans]} { - lappend spanned $cnext - incr cnext - set spanlength [lindex $colspans $cnext] - } - set others_width 0 - foreach col $spanned { - incr others_width [lindex $configured_widths $col] - if {$showing_vseps} { - incr others_width 1 - } - } - set total_spanned_width [expr {$width_max + $others_width}] - if {$thiscol_widest_header > $total_spanned_width} { - #this just allocates the extra space in the current column - which is not great. - #A proper algorithm for distributing width created by headers to all the spanned columns is needed. - #This is a tricky problem with multiple header lines and arbitrary spans. - #The calculation should probably be done on the table as a whole first and this function should just look up that result. - #Trying to calculate on a specific column only is unlikely to be easy or efficient. - set needed [expr {$thiscol_widest_header - $total_spanned_width}] - #puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)" - if {$defmaxw ne ""} { - set test_width [expr {min($colwidth+$needed,$defmaxw)}] - } else { - set test_width [expr {$colwidth + $needed}] - } - } - } - set width_max [expr {max($test_width,$width_max)}] - } - - #alternative to all the above shennanigans.. let the body cell data determine the size and just wrap the headers - #could also split the needed width amongst the spanned columns? configurable for whether cells expand? - set expand_first_column 1 - if {$expand_first_column} { - set colwidth $width_max - } - - #puts "---column_width $cidx = $colwidth" - return $colwidth - } - method Showing_vseps {} { - #review - show_seps and override mechanism for show_vseps show_hseps - document. - set seps [tcl::dict::get $o_opts_table -show_seps] - set vseps [tcl::dict::get $o_opts_table -show_vseps] - if {$seps eq ""} { - if {$vseps eq "" || $vseps} { - return true - } - } elseif {$seps} { - if {$vseps eq "" || $vseps} { - return true - } - } else { - if {$vseps ne "" && $vseps} { - return true - } - } - return false - } - - method column_datawidth {index_expression args} { - set opts [tcl::dict::create\ - -headers 0\ - -footers 0\ - -colspan unspecified\ - -data 1\ - -cached 1\ - ] - #NOTE: -colspan any is not the same as * - # - #-colspan is relevant to header/footer data only - foreach {k v} $args { - switch -- $k { - -headers - -footers - -colspan - -data - -cached { - tcl::dict::set opts $k $v - } - default { - error "column_datawidth unrecognised flag '$k'. Known flags: [tcl::dict::keys $opts]" - } - } - } - set opt_colspan [tcl::dict::get $opts -colspan] - switch -- $opt_colspan { - * - unspecified {} - any { - error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0 (use header_colspans_numeric to get actual spans)" - } - default { - if {![string is integer -strict $opt_colspan]} { - error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0" - } - } - } - - - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - - if {[tcl::dict::get $opts -cached]} { - set hwidest 0 - set bwidest 0 - set fwidest 0 - if {[tcl::dict::get $opts -headers]} { - if {$opt_colspan in {* unspecified}} { - set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - } else { - #this is not cached - # -- --- --- --- - set colheaders [tcl::dict::get $o_columndefs $cidx -headers] - set all_colspans_by_header [my header_colspans_numeric] - set hlist [list] - tcl::dict::for {hrow cspans} $all_colspans_by_header { - set s [lindex $cspans $cidx] - if {$s eq $opt_colspan} { - lappend hlist [lindex $colheaders $hrow] - } - } - if {[llength $hlist]} { - set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] - } else { - set hwidest 0 - } - # -- --- --- --- - } - } - if {[tcl::dict::get $opts -data]} { - set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - } - if {[tcl::dict::get $opts -footers]} { - #TODO! - #set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthfooterseen] - } - return [expr {max($hwidest,$bwidest,$fwidest)}] - } - - #assert cidx is >=0 integer in valid range of keys for o_columndefs - set values [list] - set hwidest 0 - if {[tcl::dict::get $opts -headers]} { - if {$opt_colspan in {* unspecified}} { - lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] - } else { - # -- --- --- --- - set colheaders [tcl::dict::get $o_columndefs $cidx -headers] - set all_colspans_by_header [my header_colspans_numeric] - set hlist [list] - tcl::dict::for {hrow cspans} $all_colspans_by_header { - set s [lindex $cspans $cidx] - if {$s eq $opt_colspan} { - lappend hlist [lindex $colheaders $hrow] - } - } - if {[llength $hlist]} { - set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] - } else { - set hwidest 0 - } - # -- --- --- --- - } - } - if {[tcl::dict::get $opts -data]} { - if {[tcl::dict::exists $o_columndata $cidx]} { - lappend values {*}[tcl::dict::get $o_columndata $cidx] - } - } - if {[tcl::dict::get $opts -footers]} { - lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] - } - if {[llength $values]} { - set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] - set widest [expr {max($valwidest,$hwidest)}] - } else { - set widest $hwidest - } - return $widest - } - #print1 uses basic column joining - useful for testing/debug especially with colspans - method print1 {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0 } - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set colposn 0 - set numposns [llength $cols] - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - lappend blocks [my get_column_by_index $c {*}$flags] - incr colposn - } - if {[llength $blocks]} { - return [textblock::join -- {*}$blocks] - } else { - return "No columns matched" - } - } - method columncalc_spans {allocmethod} { - set colwidths [tcl::dict::create] ;# to use tcl::dict::incr - set colspace_added [tcl::dict::create] - - set ordered_spans [tcl::dict::create] - tcl::dict::for {col spandata} [my spangroups] { - set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] - set minwidth [tcl::dict::get $o_columndefs $col -minwidth] - set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] - if {$minwidth ne ""} { - if {$dwidth < $minwidth} { - set dwidth $minwidth - } - } - if {$maxwidth ne ""} { - if {$dwidth > $maxwidth} { - set dwidth $maxwidth - } - } - tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered - tcl::dict::set colspace_added $col 0 - - set spanlengths [tcl::dict::get $spandata spanlengths] - foreach slen $spanlengths { - set spans [tcl::dict::get $spandata spangroups $slen] - set spans [lsort -index 7 -integer $spans] - foreach s $spans { - set hwidth [tcl::dict::get $s headerwidth] - set hrow [tcl::dict::get $s hrow] - set scol [tcl::dict::get $s startcol] - tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth - tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth - } - } - } - - #safe jumptable test - #dict for {spanid spandata} $ordered_spans {} - tcl::dict::for {spanid spandata} $ordered_spans { - lassign [split $spanid ,] startcol hrow - set memcols [tcl::dict::get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios - set colids [tcl::dict::keys $memcols] - set hwidth [tcl::dict::get $spandata headerwidth] - set num_cols_spanned [tcl::dict::size $memcols] - if {$num_cols_spanned == 1} { - set col [lindex $memcols 0] - set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] - if {$space_to_alloc > 0} { - set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] - if {$maxwidth ne ""} { - if {$maxwidth > [tcl::dict::get $colwidths $col]} { - set can_alloc [expr {$maxwidth - [tcl::dict::get $colwidths $col]}] - } else { - set can_alloc 0 - } - set will_alloc [expr {min($space_to_alloc,$can_alloc)}] - } else { - set will_alloc $space_to_alloc - } - if {$will_alloc} { - #tcl::dict::set colwidths $col $hwidth - tcl::dict::incr colwidths $col $will_alloc - tcl::dict::set colspace_added $col $will_alloc - } - #log! - #if {$will_alloc < $space_to_alloc} { - # #todo - debug only - # puts stderr "max width $maxwidth hit for col $col - cannot allocate extra [expr {$space_to_alloc - $will_alloc}]" - #} - } - } elseif {$num_cols_spanned > 1} { - set spannedwidth 0 - foreach col $colids { - incr spannedwidth [tcl::dict::get $colwidths $col] - } - set space_to_alloc [expr {$hwidth - $spannedwidth}] - if {[my Showing_vseps]} { - set sepcount [expr {$num_cols_spanned -1}] - incr space_to_alloc -$sepcount - } - #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added - switch -- $allocmethod { - least { - #add to least-expanded each time - #safer than method 1 - pretty balanced - if {$space_to_alloc > 0} { - for {set i 0} {$i < $space_to_alloc} {incr i} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] - foreach testcolid $ordered_all_colids { - if {$testcolid in $colids} { - #assert - we will always find a match - set colid $testcolid - break - } - } - tcl::dict::incr colwidths $colid - tcl::dict::incr colspace_added $colid - } - } - } - least_unmaxed { - #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth - #(we should be able to collapse column width to zero and have header colspans gracefully respond) - #add to least-expanded each time - #safer than method 1 - pretty balanced - if {$space_to_alloc > 0} { - for {set i 0} {$i < $space_to_alloc} {incr i} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] - set colid "" - foreach testcolid $ordered_all_colids { - set maxwidth [tcl::dict::get $o_columndefs $testcolid -maxwidth] - set can_alloc [expr {$maxwidth eq "" || $maxwidth > [tcl::dict::get $colwidths $testcolid]}] - if {$testcolid in $colids} { - if {$can_alloc} { - set colid $testcolid - break - } else { - #remove from future consideration in for loop - #log! - #puts stderr "max width $maxwidth hit for col $testcolid" - tcl::dict::unset colspace_added $testcolid - } - } - } - if {$colid ne ""} { - tcl::dict::incr colwidths $colid - tcl::dict::incr colspace_added $colid - } - } - } - } - all { - #adds space to all columns - not just those spanned - risk of underallocating and truncating some headers! - #probably not a good idea for tables with complex headers and spans - while {$space_to_alloc > 0} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_colids [tcl::dict::keys $ordered_colspace_added] - - foreach col $ordered_colids { - tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col - incr space_to_alloc -1 - if {$space_to_alloc == 0} { - break - } - } - } - - } - } - } - } - - set column_widths [tcl::dict::values $colwidths] - #todo - -maxwidth etc - set table_minwidth [tcl::dict::get $o_opts_table -minwidth] ;#min width including frame elements - if {[tcl::string::is integer -strict $table_minwidth]} { - set contentwidth [tcl::mathop::+ {*}$column_widths] - set twidth $contentwidth - if {[my Showing_vseps]} { - incr twidth [llength $column_widths] - incr twidth -1 - } - if {[tcl::dict::get $o_opts_table -show_edge]} { - incr twidth 2 - } - # - set shortfall [expr {$table_minwidth - $twidth}] - if {$shortfall > 0} { - set space_to_alloc $shortfall - while {$space_to_alloc > 0} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_colids [tcl::dict::keys $ordered_colspace_added] - - foreach col $ordered_colids { - tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col - incr space_to_alloc -1 - if {$space_to_alloc == 0} { - break - } - } - } - set column_widths [tcl::dict::values $colwidths] - } - - } - - return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] - } - - #spangroups keyed by column - method spangroups {} { - set column_count [tcl::dict::size $o_columndefs] - set spangroups [tcl::dict::create] - set headerwidths [tcl::dict::create] ;#key on col,hrow - foreach c [tcl::dict::keys $o_columndefs] { - tcl::dict::set spangroups $c [list spanlengths {}] - set spanlist [my column_get_spaninfo $c] - set index_spanlen_val 5 - set spanlist [lsort -index $index_spanlen_val -integer $spanlist] - set ungrouped $spanlist - - while {[llength $ungrouped]} { - set spanlen [lindex $ungrouped 0 $index_spanlen_val] - set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen] - set sgroup [list] - foreach p $spangroup_posns { - set spaninfo [lindex $ungrouped $p] - set hcol [tcl::dict::get $spaninfo startcol] - set hrow [tcl::dict::get $spaninfo hrow] - set header [lindex [tcl::dict::get $o_columndefs $hcol -headers] $hrow] - if {[tcl::dict::exists $headerwidths $hcol,$hrow]} { - set hwidth [tcl::dict::get $headerwidths $hcol,$hrow] - } else { - set hwidth [textblock::width $header] - tcl::dict::set headerwidths $hcol,$hrow $hwidth - } - lappend spaninfo headerwidth $hwidth - lappend sgroup $spaninfo - } - set spanlengths [tcl::dict::get $spangroups $c spanlengths] - lappend spanlengths $spanlen - tcl::dict::set spangroups $c spanlengths $spanlengths - tcl::dict::set spangroups $c spangroups $spanlen $sgroup - set ungrouped [lremove $ungrouped {*}$spangroup_posns] - } - } - return $spangroups - } - method column_get_own_spans {cidx} { - set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] - } - method column_get_spaninfo {cidx} { - set spans_by_header [my header_colspans] - set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] - set spaninfo [list] - set numcols [tcl::dict::size $o_columndefs] - #note that 'any' can occur in positions other than column 0 - meaning any remaining until next non-zero span - tcl::dict::for {hrow rawspans} $spans_by_header { - set thiscol_spanval [lindex $rawspans $cidx] - if {$thiscol_spanval eq "any" || $thiscol_spanval > 0} { - set spanstartcol $cidx ;#own column - if {$thiscol_spanval eq "any"} { - #scan right to first non-zero to get actual length of 'any' span - #REVIEW! - set spanlen 1 - for {set i [expr {$cidx+1}]} {$i < $numcols} {incr i} { - #abort at next any or number or empty string - if {[lindex $rawspans $i] ne "0"} { - break - } - incr spanlen - } - #set spanlen [expr {$numcols - $cidx}] - } else { - set spanlen $thiscol_spanval - } - } else { - #look left til we see an any or a non-zero value - for {set i $cidx} {$i > -1} {incr i -1} { - set s [lindex $rawspans $i] - if {$s eq "any" || $s > 0} { - set spanstartcol $i - if {$s eq "any"} { - #REVIEW! - #set spanlen [expr {$numcols - $i}] - set spanlen 1 - #now scan right to see how long the 'any' actually is - for {set j [expr {$i+1}]} {$j < $numcols} {incr j} { - if {[lindex $rawspans $j] ne "0"} { - break - } - incr spanlen - } - } else { - set spanlen $s - } - break - } - } - } - #assert - we should always find 1 answer for each header row - lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen] - } - return $spaninfo - } - method calculate_column_widths {args} { - set column_count [tcl::dict::size $o_columndefs] - - set opts [tcl::dict::create\ - -algorithm $o_column_width_algorithm\ - ] - foreach {k v} $args { - switch -- $k { - -algorithm { - tcl::dict::set opts $k $v - } - default { - error "Unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set opt_algorithm [tcl::dict::get $opts -algorithm] - #puts stderr "--- recalculating column widths -algorithm $opt_algorithm" - set known_algorithms [list basic simplistic span span2] - switch -- $opt_algorithm { - basic { - #basic column by column - This allocates extra space to first span/column as they're encountered. - #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans - #The header values can extend over some of the spanned columns - but not optimally so. - set o_calculated_column_widths [list] - for {set c 0} {$c < $column_count} {incr c} { - lappend o_calculated_column_widths [my basic_column_width $c] - } - } - simplistic { - #just uses the widest column data or header element. - #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column - #This is a conservative option potentially useful in testing/debugging. - set o_calculated_column_widths [list] - for {set c 0} {$c < $column_count} {incr c} { - lappend o_calculated_column_widths [my column_width_configured $c] - } - } - span { - #widest of smallest spans first method - #set calcresult [my columncalc_spans least] - set calcresult [my columncalc_spans least_unmaxed] - set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] - } - span2 { - #allocates more evenly - but truncates headers sometimes - set calcresult [my columncalc_spans all] - set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] - } - default { - error "calculate_column_widths unknown algorithm $opt_algorithm. Known algorithms: $known_algorithms" - } - } - #remember the last algorithm used - set o_column_width_algorithm $opt_algorithm - return $o_calculated_column_widths - } - method print2 {args} { - variable full_column_cache - set full_column_cache [tcl::dict::create] - - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set colposn 0 - set numposns [llength $cols] - set padwidth 0 - set table "" - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - #lappend blocks [my get_column_by_index $c {*}$flags] - #todo - only check and store in cache if table has header or footer colspans > 1 - if {[tcl::dict::exists $full_column_cache $c]} { - #puts "!!print used full_column_cache for $c" - set columninfo [tcl::dict::get $full_column_cache $c] - } else { - set columninfo [my get_column_by_index $c -return dict {*}$flags] - tcl::dict::set full_column_cache $c $columninfo - } - set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] - - if {$table eq ""} { - set table $nextcol - set height [textblock::height $table] ;#only need to get height once at start - } else { - set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] - set table [overtype::renderspace -expand_right 1 -transparent $TSUB $table[unset table] $nextcol] - #JMN - - #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] - #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] - } - incr padwidth $bodywidth - incr colposn - } - - if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - - # using -startcolumn to do slightly less work - method print3 {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set numposns [llength $cols] - set colposn 0 - set padwidth 0 - set table "" - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - set columninfo [my get_column_by_index $c -return dict {*}$flags] - set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] - - if {$table eq ""} { - set table $nextcol - set height [textblock::height $table] ;#only need to get height once at start - } else { - set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] - } - incr padwidth $bodywidth - incr colposn - } - - if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - - #print headers and body using different join mechanisms - # using -startcolumn to do slightly less work - method print {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set numposns [llength $cols] - set colposn 0 - set padwidth 0 - set header_build "" - set body_blocks [list] - set headerheight 0 - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - set columninfo [my get_column_by_index $c -return dict {*}$flags] - #set nextcol [tcl::dict::get $columninfo column] - set bodywidth [tcl::dict::get $columninfo bodywidth] - set headerheight [tcl::dict::get $columninfo headerheight] - #set nextcol_lines [split $nextcol \n] - #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] - #set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n] - set nextcol_header [tcl::dict::get $columninfo header] - set nextcol_body [tcl::dict::get $columninfo body] - - if {$header_build eq "" && ![llength $body_blocks]} { - set header_build $nextcol_header - lappend body_blocks $nextcol_body - } else { - if {$headerheight > 0} { - set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] - } - lappend body_blocks $nextcol_body - #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] - } - incr padwidth $bodywidth - incr colposn - } - if {![llength $body_blocks]} { - set body_build "" - } else { - #body blocks should not be ragged - so can use join_basic - set body_build [textblock::join_basic -- {*}$body_blocks] - } - if {$headerheight > 0} { - set table [tcl::string::cat $header_build \n $body_build] - } else { - set table $body_build - } - - if {[llength $cols]} { - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - method print_bodymatrix {} { - set m [my as_matrix] - $m format 2string - } - - #*** !doctools - #[list_end] - }] - #*** !doctools - # [list_end] [comment {- end enumeration provider_classes }] - #[list_end] [comment {- end itemized list textblock::class groupings -}] - } - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# -#Note: A textblock does not necessarily have lines the same length - either in number of characters or print-width -# -tcl::namespace::eval textblock { - tcl::namespace::eval cd { - #todo - save and restore existing tcl::namespace::export in case macros::cd has default exports in future - tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export *} - tcl::namespace::import ::term::ansi::code::macros::cd::* - tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} - } - proc spantest {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2] - $t configure_column 0 -header_colspans {3 4 5 any 2} - $t configure_column 2 -headers {"" "" "" "" c2span2_etc} - $t configure_column 2 -header_colspans {0 0 0 0 2} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - proc spantest1 {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers [list "span3-any longer than other span any" "1-span4\n2-span4 second line" "span-any short aligned?" "span5/5 longest etc blah 123" span2] - $t configure_column 0 -header_colspans {any 4 any 5 2} - $t configure_column 2 -headers {"" "" "" "" c2span2_etc} - $t configure_column 2 -header_colspans {0 0 0 0 2} - $t configure_column 3 -header_colspans {1 0 0 0 0} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - $t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs) - return $t - } - - #more complex colspans - proc spantest2 {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} - $t configure_column 0 -header_colspans {3 4 1 any 2} - $t configure_column 1 -header_colspans {0 0 2 0 0} - $t configure_column 2 -headers {"" "" "" "" c2span2} - $t configure_column 2 -header_colspans {0 0 0 0 2} - $t configure_column 3 -header_colspans {1 0 2 0 0} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - proc spantest3 {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1} - $t configure_column 0 -header_colspans {3 4 1 any 2 1} - $t configure_column 1 -header_colspans {0 0 4 0 0 1} - $t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"} - $t configure_column 2 -headers {"" "" "" "" "" c2span2} - $t configure_column 2 -header_colspans {0 0 0 0 1 2} - $t configure_column 4 -headers {"4" "444" "" "" "" "44"} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - - - - proc periodic {args} { - #For an impressive interactive terminal app (javascript) - # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_dict { - *proc -name textblock::periodic -help "A rudimentary periodic table - This is primarily a test of textblock::class::table" - - -return -default table\ - -choices {table tableobject}\ - -help "default choice 'table' returns the displayable table output" - -compact -default 1 -type boolean -help "compact true defaults: -show_vseps 0 -show_header 0 -show_edge 0" - -frame -default 1 -type boolean - -show_vseps -default "" -type boolean - -show_header -default "" -type boolean - -show_edge -default "" -type boolean - -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - *values -min 0 -max 0 - } $args] opts] - - set opt_return [tcl::dict::get $opts -return] - if {[tcl::dict::get $opts -forcecolour]} { - set fc forcecolour - } else { - set fc "" - } - - #examples ptable.com - set elements [list\ - 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ - 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ - 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ - 4 K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr\ - 5 Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe\ - 6 Cs Ba "" Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn\ - 7 Fr Ra "" Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og\ - " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ - "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ - "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ - ] - - set type_colours [list] - - set ecat [tcl::dict::create] - - set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] - set ansi [a+ {*}$fc web-black Web-gold] - set val [list ansi $ansi cat alkaline_earth] - foreach e $cat_alkaline_earth { - tcl::dict::set ecat $e $val - } - - set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - #set ansi [a+ {*}$fc web-black Web-lightgreen] - set ansi [a+ {*}$fc black Term-113] - set val [list ansi $ansi cat reactive_nonmetal] - foreach e $cat_reactive_nonmetal { - tcl::dict::set ecat $e $val - } - - set cat [list Li Na K Rb Cs Fr] - #set ansi [a+ {*}$fc web-black Web-Khaki] - set ansi [a+ {*}$fc black Term-lightgoldenrod2] - set val [list ansi $ansi cat alkali_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - #set ansi [a+ {*}$fc web-black Web-lightsalmon] - set ansi [a+ {*}$fc black Term-orange1] - set val [list ansi $ansi cat transition_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] - set val [list ansi $ansi cat post_transition_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list B Si Ge As Sb Te At] - #set ansi [a+ {*}$fc web-black Web-turquoise] - set ansi [a+ {*}$fc black Brightcyan] - set val [list ansi $ansi cat metalloids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] - set val [list ansi $ansi cat noble_gases] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] - set val [list ansi $ansi cat actinoids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - #set ansi [a+ {*}$fc web-black Web-tan] - set ansi [a+ {*}$fc black Term-tan] - set val [list ansi $ansi cat lanthanoids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set ansi [a+ {*}$fc web-black Web-whitesmoke] - set val [list ansi $ansi cat other] - foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { - tcl::dict::set ecat $e $val - } - - set elements1 [list] - set RST [a+] - foreach e $elements { - if {[tcl::dict::exists $ecat $e]} { - set ansi [tcl::dict::get $ecat $e ansi] - #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] - #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway - lappend elements1 $ansi$e - } else { - lappend elements1 $e - } - } - - set t [list_as_table -columns 19 -return tableobject $elements1] - #(defaults to show_hseps 0) - - #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options - - set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] - set c 0 - foreach h $header_0 { - $t configure_column $c -headers [list $h] -minwidth 2 - incr c - } - set ccount [$t column_count] - for {set c 0} {$c < $ccount} {incr c} { - $t configure_column $c -minwidth 3 - } - if {[tcl::dict::get $opts -compact]} { - #compact defaults - but let explicit arguments override - set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0] - } else { - set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1] - } - dict for {k v} $conf { - if {[dict get $opts $k] ne ""} { - dict set conf $k [dict get $opts $k] - } - } - $t configure {*}[dict get $conf] - - $t configure \ - -frametype_header light\ - -ansiborder_header [a+ {*}$fc brightwhite]\ - -ansibase_header [a+ {*}$fc Black]\ - -ansibase_body [a+ {*}$fc Black]\ - -ansiborder_body [a+ {*}$fc black]\ - -frametype block - - #-ansiborder_header [a+ {*}$fc web-white]\ - - if {$opt_return eq "table"} { - if {[dict get $opts -frame]} { - #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - set output [textblock::frame -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - } else { - set output [$t print] - } - $t destroy - return $output - } - return $t - } - - proc list_as_table {args} { - set argd [punk::args::get_dict [string map [list $::textblock::frametypes] { - -return -default table -choices {table tableobject} - -frametype -default "" -help "frame type: or dict for custom frame" - -show_edge -default "" -type boolean -help "show outer border of table" - -show_seps -default "" -type boolean - -show_vseps -default "" -type boolean -help "Show vertical table separators" - -show_hseps -default "" -type boolean -help "Show horizontal table separators - (default 0 if no existing -table supplied)" - -table -default "" -type string -help "existing table object to use" - -headers -default "" -help "list of header values. Must match number of columns" - -show_header -default "" -help "Whether to show a header row. - Leave as empty string for unspecified/automatic, - in which case it will display only if -headers list was supplied." - -action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied - if append is chosen the new values will always start at the first column" - -columns -default "" -type integer -help "Number of table columns - Will default to 2 if not using an existing -table object" - *values -min 0 -max 1 - datalist -default {} -help "flat list of table cell values which will be wrapped based on -columns value" - }] $args] - set opts [dict get $argd opts] - set datalist [dict get $argd values datalist] - - set existing_table [dict get $opts -table] - set opt_columns [dict get $opts -columns] - #set opts [tcl::dict::create\ - # -return string\ - # -frametype \uFFEF\ - # -show_edge \uFFEF\ - # -show_seps \uFFEF\ - #] - #foreach {k v} $args { - # switch -- $k { - # -return - -show_edge - -show_seps - -frametype { - # tcl::dict::set opts $k $v - # } - # default { - # error "unrecognised option '$k'. Known options [tcl::dict::keys $opts]" - # } - # } - #} - - set count [llength $datalist] - - set is_new_table 0 - if {$existing_table ne ""} { - if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} { - error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])" - } - set t $existing_table - foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} { - if {[tcl::dict::get $opts $prop] ne ""} { - $t configure $prop [tcl::dict::get $opts $prop] - } - } - if {[dict get $opts -action] eq "replace"} { - $t row_clear - } - set cols [$t column_count] - if {[tcl::string::is integer -strict $opt_columns]} { - if {$opt_columns > $cols} { - set extra [expr {$opt_columns - $cols}] - for {set c 0} {$c < $extra} {incr c} { - $t add_column - } - } elseif {$opt_columns < $cols} { - #todo - auto add blank values in the datalist - error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported" - } - set cols [$t column_count] - } - } else { - set is_new_table 1 - set headers {} - if {[tcl::dict::get $opts -headers] ne ""} { - set headers [dict get $opts -headers] - if {[tcl::dict::get $opts -show_header] eq ""} { - set show_header 1 - } else { - set show_header [tcl::dict::get $opts -show_header] - } - } else { - if {[tcl::dict::get $opts -show_header] eq ""} { - set show_header 0 - } else { - set show_header [tcl::dict::get $opts -show_header] - } - } - - if {[tcl::string::is integer -strict $opt_columns]} { - set cols $opt_columns - if {[llength $headers] && $cols != [llength $headers]} { - error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $headers])" - } - } else { - #review - if {[llength $headers]} { - set cols [llength $headers] - } else { - set cols 2 ;#seems a reasonable default - } - } - #defaults for new table only - if {[tcl::dict::get $opts -frametype] eq ""} { - tcl::dict::set opts -frametype "light" - } - if {[tcl::dict::get $opts -show_edge] eq ""} { - tcl::dict::set opts -show_edge 1 - } - if {[tcl::dict::get $opts -show_seps] eq ""} { - tcl::dict::set opts -show_seps 1 - } - if {[tcl::dict::get $opts -show_vseps] eq ""} { - tcl::dict::set opts -show_vseps 1 - } - if {[tcl::dict::get $opts -show_hseps] eq ""} { - tcl::dict::set opts -show_hseps 0 - } - - set t [textblock::class::table new\ - -show_header $show_header\ - -show_edge [tcl::dict::get $opts -show_edge]\ - -frametype [tcl::dict::get $opts -frametype]\ - -show_seps [tcl::dict::get $opts -show_seps]\ - -show_vseps [tcl::dict::get $opts -show_vseps]\ - -show_hseps [tcl::dict::get $opts -show_hseps]\ - ] - if {[llength $headers]} { - for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [lindex $headers $c] - } - } else { - for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [list $c] - } - } - } - - set full_rows [expr {$count / $cols}] - set last_items [expr {$count % $cols}] - - - set rowdata [list] - set row [list] - set i 0 - if {$full_rows > 0} { - for {set r 0} {$r < $full_rows} {incr r} { - set j [expr {$i + ($cols -1)}] - set row [lrange $datalist $i $j] - incr i $cols - lappend rowdata $row - } - } - if {$last_items > 0} { - set idx [expr {$last_items -1}] - lappend rowdata [lrange $datalist end-$idx end] - } - foreach row $rowdata { - set shortfall [expr {$cols - [llength $row]}] - if {$shortfall > 0} { - set row [concat $row [lrepeat $shortfall ""]] - } - $t add_row $row - } - #puts stdout $rowdata - if {[tcl::dict::get $opts -return] eq "table"} { - set result [$t print] - if {$is_new_table} { - $t destroy - } - return $result - } else { - return $t - } - } - #return a homogenous block of characters - ie lines all same length, all same character - #printing-width in terminal columns is not necessarily same as blockwidth even if a single char is passed (could be full-width unicode character) - #This can have ansi SGR codes - but to repeat blocks containing ansi-movements, the block should first be rendered to a static output with something like overtype::left - proc block {blockwidth blockheight {char " "}} { - if {$blockwidth < 0} { - error "textblock::block blockwidth must be an integer greater than or equal to zero" - } - if {$blockheight <= 0} { - error "textblock::block blockheight must be a positive integer" - } - if {$char eq ""} {return ""} - #using tcl::string::length is ok - if {[tcl::string::length $char] == 1} { - set row [tcl::string::repeat $char $blockwidth] - set mtrx [lrepeat $blockheight $row] - return [::join $mtrx \n] - } else { - set charblock [tcl::string::map [list \r\n \n] $char] - if {[tcl::string::last \n $charblock] >= 0} { - if {$blockwidth > 1} { - #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) - set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] - } else { - set row $charblock - } - } else { - set row [tcl::string::repeat $char $blockwidth] - } - set mtrx [lrepeat $blockheight $row] - return [::join $mtrx \n] - } - } - proc testblock {size {colour ""}} { - if {$size <1 || $size > 15} { - error "textblock::testblock only sizes between 1 and 15 inclusive supported" - } - set rainbow_list [list] - lappend rainbow_list {30 47} ;#black White - lappend rainbow_list {31 46} ;#red Cyan - lappend rainbow_list {32 45} ;#green Purple - lappend rainbow_list {33 44} ;#yellow Blue - lappend rainbow_list {34 43} ;#blue Yellow - lappend rainbow_list {35 42} ;#purple Green - lappend rainbow_list {36 41} ;#cyan Red - lappend rainbow_list {37 40} ;#white Black - lappend rainbow_list {black Yellow} - lappend rainbow_list red - lappend rainbow_list green - lappend rainbow_list yellow - lappend rainbow_list blue - lappend rainbow_list purple - lappend rainbow_list cyan - lappend rainbow_list {white Red} - - set rainbow_direction "horizontal" - set vpos [lsearch $colour vertical] - if {$vpos >= 0} { - set rainbow_direction vertical - set colour [lremove $colour $vpos] - } - set hpos [lsearch $colour horizontal] - if {$hpos >=0} { - #horizontal is the default and superfluous but allowed for symmetry - set colour [lremove $colour $hpos] - } - - - - set chars [concat [punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] - if {"noreset" in $colour} { - set RST "" - } else { - set RST [a] - } - if {"rainbow" in $colour && $rainbow_direction eq "vertical"} { - #column first - colour change each column - set c [::join $charsubset \n] - - set clist [list] - for {set i 0} {$i <$size} {incr i} { - set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] - set ansi [a+ {*}$colour2] - - set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] - lappend clist ${ansicode}$c$RST - } - if {"noreset" in $colour} { - return [textblock::join_basic -ansiresets 0 -- {*}$clist] - } else { - return [textblock::join_basic -- {*}$clist] - } - } elseif {"rainbow" in $colour} { - #direction must be horizontal - set block "" - for {set r 0} {$r < $size} {incr r} { - set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] - set ansi [a+ {*}$colour2] - set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] - set row "$ansicode" - foreach c $charsubset { - append row $c - } - append row $RST - append block $row\n - } - set block [tcl::string::trimright $block \n] - return $block - } else { - #row first - - set rows [list] - foreach ch $charsubset { - lappend rows [tcl::string::repeat $ch $size] - } - set block [::join $rows \n] - if {$colour ne ""} { - set block [a+ {*}$colour]$block$RST - } - return $block - } - } - interp alias {} testblock {} textblock::testblock - - #todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table - proc width {textblock} { - #backspaces, vertical tabs ? - if {$textblock eq ""} { - return 0 - } - #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - if {[punk::ansi::ta::detect $textblock]} { - #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) - set textblock [punk::ansi::ansistripraw $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } - return [punk::char::ansifreestring_width $textblock] - } - #when we know the block is uniform in width - just examine topline - proc widthtopline {textblock} { - set firstnl [tcl::string::first \n $textblock] - if {$firstnl >= 0} { - set tl [tcl::string::range $textblock 0 $firstnl] - } else { - set tl $textblock - } - if {[punk::ansi::ta::detect $tl]} { - set tl [punk::ansi::ansistripraw $tl] - } - return [punk::char::ansifreestring_width $tl] - } - #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. - proc string_length_line_max textblock { - tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - } - proc string_length_line_min textblock { - tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - } - proc height {textblock} { - #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le - #empty string still has height 1 (at least for left-right/right-left languages) - - #vertical tab on a proper terminal should move directly down. - #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) - - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - } - #MAINTENANCE - same as overtype::blocksize? - proc size {textblock} { - if {$textblock eq ""} { - return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings - } - #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests - if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::ansistripraw $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set width [punk::char::ansifreestring_width $textblock] - } - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - #our concept of block-height is likely to be different to other line-counting mechanisms - set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - - return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height - } - proc size_as_opts {textblock} { - set sz [size $textblock] - return [dict create -width [dict get $sz width] -height [dict get $sz height]] - } - proc size_as_list {textblock} { - set sz [size $textblock] - return [list [dict get $sz width] [dict get $sz height]] - } - #must be able to handle block as string with or without newlines - #if no newlines - attempt to treat as a list - #must handle whitespace-only string,list elements, and/or lines. - #reviewing 2024 - this seems like too much magic! - proc width1 {block} { - if {$block eq ""} { - return 0 - } - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set block [textutil::tabify::untabify2 $block $tw] - if {[tcl::string::last \n $block] >= 0} { - return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]] - } - if {[catch {llength $block}]} { - return [::punk::char::string_width [ansistrip $block]] - } - if {[llength $block] == 0} { - #could be just a whitespace string - return [tcl::string::length $block] - } - return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]] - } - - #we shouldn't make textblock depend on the punk pipeline system - #pipealias ::textblock::padleft .= {list $input [tcl::string::repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- |? ?-which right|left|centre? ?-width auto|? ?-within_ansi 1|0?" - foreach {k v} $args { - switch -- $k { - -padchar - -which - -width - -overflow - -within_ansi { - tcl::dict::set opts $k $v - } - default { - error "textblock::pad unrecognised option '$k'. Usage: $usage" - } - } - } - # -- --- --- --- --- --- --- --- --- --- - set padchar [tcl::dict::get $opts -padchar] - #if padchar width (screen width) > 1 - length calculations will not be correct - #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map - #The caller may also use ansi within the padchar - although it's unlikely to be efficient. - # -- --- --- --- --- --- --- --- --- --- - set known_whiches [list l left r right c center centre] - set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] - switch -- $opt_which { - center - centre - c { - set which c - } - left - l { - set which l - } - right - r { - set which r - } - default { - error "textblock::pad unrecognised value for -which option. Known values $known_whiches" - } - } - # -- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - switch -- $opt_width { - "" - auto { - set width auto - } - default { - if {![tcl::string::is integer -strict $opt_width] || $opt_width < 0} { - error "textblock::pad -width must be an integer >=0" - } - set width $opt_width - } - } - # -- --- --- --- --- --- --- --- --- --- - set opt_withinansi [tcl::dict::get $opts -within_ansi] - switch -- $opt_withinansi { - 0 - 1 {} - default { - set opt_withinansi 2 - } - } - # -- --- --- --- --- --- --- --- --- --- - - set datawidth [textblock::width $block] - if {$width eq "auto"} { - set width $datawidth - } - - set lines [list] - - set padcharsize [punk::ansi::printing_length $padchar] - set pad_has_ansi [punk::ansi::ta::detect $padchar] - if {$block eq ""} { - #we need to treat as a line - set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - #TODO - #review - what happens when padchar has ansi, or the width would split a double-wide unicode char? - #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) - #we should use overtype with suitable replacement char (space?) for chopped double-wides - if {!$pad_has_ansi} { - return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] - } else { - set base [tcl::string::repeat " " $width] - return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - } - - #review - tcl format can only pad with zeros or spaces? - #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - if 0 { - #review - surprisingly, this doesn't seem to be a performance win - #No detectable diff on small blocks - slightly worse on large blocks - if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { - #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position - #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. - set block [tcl::string::map [list \r\n \n] $block] - if {$which eq "l"} { - set fmt "%+${padchar}*s" - } else { - set fmt "%-${padchar}*s" - } - foreach ln [split $block \n] { - #set lnwidth [punk::char::ansifreestring_width $ln] - set lnwidth [punk::char::grapheme_width_cached $ln] - set lnlen [tcl::string::length $ln] - set diff [expr $lnwidth - $lnlen] - #we need trickwidth to get format to pad a string with a different terminal width compared to string length - set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) - lappend lines [format $fmt $trickwidth $ln] - } - return [::join $lines \n] - } - } - - #todo? special case trailing double-reset - insert between resets? - set lnum 0 - if {[punk::ansi::ta::detect $block]} { - set parts [punk::ansi::ta::split_codes $block] - } else { - #single plaintext part - set parts [list $block] - } - set line_chunks [list] - set line_len 0 - set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad - foreach {pt ansi} $parts { - if {$pt ne ""} { - set has_nl [expr {[tcl::string::last \n $pt]>=0}] - if {$has_nl} { - set pt [tcl::string::map [list \r\n \n] $pt] - set partlines [split $pt \n] - } else { - set partlines [list $pt] - } - set last [expr {[llength $partlines]-1}] - set p 0 - foreach pl $partlines { - lappend line_chunks $pl - #incr line_len [punk::char::ansifreestring_width $pl] - incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW - if {$p != $last} { - #do padding - set missing [expr {$width - $line_len}] - if {$missing > 0} { - #commonly in a block - many lines will have the same pad - cache based on missing - - #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars - if {[tcl::dict::exists $pad_cache $missing]} { - set pad [tcl::dict::get $pad_cache $missing] - } else { - set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { - set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] - } else { - set base [tcl::string::repeat " " $missing] - set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - dict set pad_cache $missing $pad - } - switch -- $which-$opt_withinansi { - r-0 { - lappend line_chunks $pad - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { - lappend line_chunks $pad - } - l-0 { - set line_chunks [linsert $line_chunks 0 $pad] - } - l-1 { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - l-2 { - if {$lnum == 0} { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - } - } - lappend lines [::join $line_chunks ""] - set line_chunks [list] - set line_len 0 - incr lnum - } - incr p - } - } else { - #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes - lappend line_chunks "" - } - #don't let trailing empty ansi affect the line_chunks length - if {$ansi ne ""} { - lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? - } - } - #pad last line - set missing [expr {$width - $line_len}] - if {$missing > 0} { - if {[tcl::dict::exists $pad_cache $missing]} { - set pad [tcl::dict::get $pad_cache $missing] - } else { - set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { - set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] - } else { - set base [tcl::string::repeat " " $missing] - set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - } - #set pad [tcl::string::repeat $padchar $missing] - switch -- $which-$opt_withinansi { - r-0 { - lappend line_chunks $pad - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - #lappend line_chunks $pad - } - l-0 { - #if {[lindex $line_chunks 0] eq ""} { - # set line_chunks [linsert $line_chunks 2 $pad] - #} else { - # set line_chunks [linsert $line_chunks 0 $pad] - #} - set line_chunks [linsert $line_chunks 0 $pad] - } - l-1 { - #set line_chunks [linsert $line_chunks 0 $pad] - set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] - } - l-2 { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - } - lappend lines [::join $line_chunks ""] - return [::join $lines \n] - } - - #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single - #resulting list is no longer a valid ansisplit list - proc _insert_before_text_or_last_ansi {str ansisplits} { - if {[llength $ansisplits] == 1} { - #ansisplits was a split on plaintext only - return [list $str [lindex $ansisplits 0]] - } elseif {[llength $ansisplits] == 0} { - return [list $str] - } - if {[llength $ansisplits] %2 != 1} { - error "_insert_before_text_or_last_ansi ansisplits list is not a valid resultlist from an ansi split - must be odd number of elements pt,ansi,pt,ansi...pt" - } - set out [list] - set i 0 - set i_last_code [expr {[llength $ansisplits]-3}] ;#would normally be -2 - but our i is jumping to each pt - not every element - foreach {pt code} $ansisplits { - if {$pt ne ""} { - return [lappend out $str {*}[lrange $ansisplits $i end]] - } - if {$i == $i_last_code} { - return [lappend out $str {*}[lrange $ansisplits $i end]] - } - #code being empty can only occur when we have reached last pt - #we have returned by then. - lappend out $code - incr i 2 - } - error "_insert_before_text_or_last_ansi failed on input str:[ansistring VIEW $str] ansisplits:[ansistring VIEW $ansisplits]" - } - proc pad_test {block} { - set width [textblock::width $block] - set padtowidth [expr {$width + 10}] - set left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - set left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - set left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - set right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - set right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - set right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] - - set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] - - set t [textblock::list_as_table -columns 3 -return tableobject $testlist] - $t configure_column 0 -headers [list "ansi"] - $t configure_column 1 -headers [list "Left"] - $t configure_column 2 -headers [list "Right"] - $t configure -show_header 1 - puts stdout [$t print] - return $t - } - - proc pad_test_blocklist {blocklist args} { - set opts [tcl::dict::create\ - -description ""\ - -blockheaders ""\ - ] - foreach {k v} $args { - switch -- $k { - -description - -blockheaders { - tcl::dict::set opts $k $v - } - default { - error "pad_test_blocklist unrecognised option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set opt_blockheaders [tcl::dict::get $opts -blockheaders] - set bheaders [tcl::dict::create] - if {$opt_blockheaders ne ""} { - set b 0 - foreach h $opt_blockheaders { - if {$b < [llength $blocklist]} { - tcl::dict::set bheaders $b $h - } - incr b - } - } - - set b 0 - set blockinfo [tcl::dict::create] - foreach block $blocklist { - set width [textblock::width $block] - tcl::dict::set blockinfo $b width $width - set padtowidth [expr {$width + 3}] - tcl::dict::set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - tcl::dict::set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - tcl::dict::set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - tcl::dict::set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - tcl::dict::set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - tcl::dict::set blockinfo $b right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] - incr b - } - - set r0 [list "0"] - set r1 [list "1"] - set r2 [list "2"] - set r3 [list "column\ncolours"] - - #1 - #test without table padding - #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering - #(basically a mechanism to add extra resets at start and end of each line) - #dict for {b bdict} $blockinfo { - # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] - # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] - # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] - #} - - #2 - the more useful one? - tcl::dict::for {b bdict} $blockinfo { - lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] - lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] - lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] - lappend r3 "" "" - } - - set rows [concat $r0 $r1 $r2 $r3] - - set column_ansi [a+ web-white Web-Gray] - - set t [textblock::list_as_table -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows] - $t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi - set col 1 - tcl::dict::for {b bdict} $blockinfo { - if {[tcl::dict::exists $bheaders $b]} { - set hdr [tcl::dict::get $bheaders $b] - } else { - set hdr "Block $b" - } - $t configure_column $col -headers [list $hdr "Left"] -minwidth [expr {$padtowidth + 2}] - $t configure_column $col -header_colspans 2 -ansibase $column_ansi - incr col - $t configure_column $col -headers [list "-" "Right"] -minwidth [expr {$padtowidth + 2}] -ansibase $column_ansi - incr col - } - $t configure -show_header 1 - puts stdout [$t print] - return $t - } - proc pad_example {} { - set headers [list] - set blocks [list] - - lappend blocks "[textblock::testblock 4 rainbow]" - lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" - - lappend blocks "[textblock::testblock 4 rainbow][a]" - lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" - - lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" - lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}]" - lappend headers "rainbow 4x4\nno line resets\nnothing trailing" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" - lappend headers "rainbow 4x4\nno line resets\ntrailing reset" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" - lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" - - set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] - } - proc pad_example2 {} { - set headers [list] - set blocks [list] - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" - - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" - - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" - - set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] - } - - - #playing with syntax - - # pipealias ::textblock::join_width .= {list $lhs [tcl::string::repeat " " $w1] $rhs [tcl::string::repeat " " $w2]} {| - # /2,col1/1,col2/3 - # >} punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| - # >} punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] - set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] - set testblock [textblock::testblock 15 rainbow] - set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] - set framed [textblock::frame -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] - } - - - proc example {args} { - set opts [tcl::dict::create -forcecolour 0] - foreach {k v} $args { - switch -- $k { - -forcecolour { - tcl::dict::set opts $k $v - } - default { - error "textblock::example unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]" - } - } - } - set opt_forcecolour 0 - if {[tcl::dict::get $opts -forcecolour]} { - set fc forcecolour - set opt_forcecolour 1 - } else { - set fc "" - } - set pleft [>punk . rhs] - set pright [>punk . lhs] - set prightair [>punk . lhs_air] - set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] - set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] - set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] - set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] - set RST [a] - set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] - set punks [textblock::join -- $pleft $pright] - set pleft_greenb $greenb$pleft$RST - set pright_redb $redb$pright$RST - set prightair_cyanb $cyanb$prightair$RST - set cpunks [textblock::join -- $pleft_greenb $pright_redb] - set out "" - append out $punks \n - append out $cpunks \n - append out [textblock::join -- $punks $cpunks] \n - set 2frames_a [textblock::join -- [textblock::frame $cpunks] [textblock::frame $punks]] - append out $2frames_a \n - set 2frames_b [textblock::join -- [textblock::frame -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -ansiborder $greenb -title "fancypunks" $cpunks]] - append out [textblock::frame -title "punks" $2frames_b\n$RST$2frames_a] \n - set fancy [overtype::right [overtype::left [textblock::frame -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nL\nI\nF\nE"] - set spantable [[spantest] print] - append out [textblock::join -- $fancy " " $spantable] \n - #append out [textblock::frame -title gr $gr0] - append out [textblock::periodic -forcecolour $opt_forcecolour] - return $out - } - - proc example3 {{text "test\netc\nmore text"}} { - package require patternpunk - .= textblock::join -- [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join -- " " |> .=>1 textblock::join -- $text |> .=>1 textblock::join -- [>punk . rhs] |> .=>1 textblock::join -- [punk::lib::list_as_lines -- [lrepeat 7 " | "]] - } - proc example2 {{text "test\netc\nmore text"}} { - package require patternpunk - .= textblock::join\ - --\ - [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7 8]]\ - [>punk . lhs]\ - " "\ - $text\ - [>punk . rhs]\ - [punk::lib::list_as_lines -- [lrepeat 8 " | "]] - } - proc table {args} { - #todo - use punk::args - upvar ::textblock::class::opts_table_defaults toptdefaults - set defaults [tcl::dict::create\ - -rows [list]\ - -headers [list]\ - -return string\ - ] - - - set defaults [tcl::dict::merge $defaults $toptdefaults] ;# -title -frametype -show_header etc - set opts [tcl::dict::merge $defaults $args] - # -- --- --- --- - set opt_return [tcl::dict::get $opts -return] - set opt_rows [tcl::dict::get $opts -rows] - set opt_headers [tcl::dict::get $opts -headers] - # -- --- --- --- - set topts [tcl::dict::create] - set toptkeys [tcl::dict::keys $toptdefaults] - tcl::dict::for {k v} $opts { - if {$k in $toptkeys} { - tcl::dict::set topts $k $v - } - } - set t [textblock::class::table new {*}$topts] - - foreach h $opt_headers { - $t add_column -headers [list $h] - } - if {[$t column_count] == 0} { - if {[llength $opt_rows]} { - set r0 [lindex $opt_rows 0] - foreach c $r0 { - $t add_column - } - } - } - foreach r $opt_rows { - $t add_row $r - } - - - - if {$opt_return eq "string"} { - set result [$t print] - $t destroy - return $result - } else { - return $t - } - } - - variable frametypes - set frametypes [list light heavy arc double block block1 block2 block2hack ascii altg] - #class::table needs to be able to determine valid frametypes - proc frametypes {} { - variable frametypes - return $frametypes - } - proc frametype {f} { - #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - switch -- $f { - light - heavy - arc - double - block - block1 - block2 - block2hack - ascii - altg { - return [tcl::dict::create category predefined type $f] - } - default { - set is_custom_dict_ok 1 - if {[llength $f] %2 == 0} { - #custom dict may leave out keys - but cannot have unknown keys - foreach {k v} $f { - switch -- $k { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - default { - #k not in custom_keys - set is_custom_dict_ok 0 - break - } - } - } - } else { - set is_custom_dict_ok 0 - } - if {!$is_custom_dict_ok} { - error "frame option -type must be one of known types: $::textblock::frametypes or a dictionary with any of keys hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - set custom_frame [tcl::dict::merge $default_custom $f] - return [tcl::dict::create category custom type $custom_frame] - } - } - } - variable framedef_cache [tcl::dict::create] - proc framedef {args} { - #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. - #e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy. - #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. - #the arc set can't even join to itself e.g with curved equivalents of T-like shapes - - #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. - variable framedef_cache - set cache_key $args - if {[tcl::dict::exists $framedef_cache $cache_key]} { - return [tcl::dict::get $framedef_cache $cache_key] - } - - set argopts [lrange $args 0 end-1] - set f [lindex $args end] - - #here we avoid the punk::args usage on the happy path, even though punk::args is fairly fast, in favour of an even faster literal switch on the happy path - #this means we have some duplication in where our flags/opts are defined: here in opts, and in spec below to give nicer error output without affecting performance. - #It also means we can't specify checks on the option types etc - set opts [tcl::dict::create\ - -joins ""\ - -boxonly 0\ - ] - set bad_option 0 - foreach {k v} $argopts { - switch -- $k { - -joins - -boxonly { - tcl::dict::set opts $k $v - } - default { - set bad_option - break - } - } - } - if {[llength $args] % 2 == 0 || $bad_option} { - #no framedef supplied, or unrecognised opt seen - set spec [string map [list $::textblock::frametypes] { - *proc -name textblock::framedef - -joins -default "" -help "List of join directions, any of: up down left right - or those combined with another frametype e.g left-heavy down-light" - -boxonly -default 0 -help "-boxonly true restricts results to the corner,vertical and horizontal box elements - It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj" - *values -min 1 -max 1 - frametype -choices "" -choiceprefix 0 -help "name from the predefined frametypes - or an adhoc dictionary." - }] - #append spec \n "frametype -help \"A predefined \"" - punk::args::get_dict $spec $args - return - } - - set joins [tcl::dict::get $opts -joins] - set boxonly [tcl::dict::get $opts -boxonly] - - - #sorted order down left right up - #1 x choose 4 - #4 x choose 3 - #6 x choose 2 - #4 x choose 1 - #15 combos - - set join_directions [list] - #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode - #e.g down-light, up-heavy - set join_targets [tcl::dict::create left "" down "" right "" up ""] - foreach jt $joins { - lassign [split $jt -] direction target - if {$target ne ""} { - tcl::dict::set join_targets $direction $target - } - lappend join_directions $direction - } - set join_directions [lsort -unique $join_directions] - set do_joins [::join $join_directions _] - - - switch -- $f { - "altg" { - #old style ansi escape sequences with alternate graphics page G0 - set hl [cd::hl] - set hlt $hl - set hlb $hl - set vl [cd::vl] - set vll $vl - set vlr $vl - set tlc [cd::tlc] - set trc [cd::trc] - set blc [cd::blc] - set brc [cd::brc] - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - #No join targets available to join altg to other box styles - switch -- $do_joins { - down { - #1 - set blc [punk::ansi::g0 t] ;#(ltj) - set brc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } left { - #2 - set tlc [punk::ansi::g0 w] ;#(ttj) - set blc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - right { - #3 - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 v] ;#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - up { - #4 - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - } - down_left { - #5 - set blc [punk::ansi::g0 n] ;#(fwj) - set tlc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - down_right { - #6 - set blc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 n] ;#(fwj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_up { - #7 - set blc [punk::ansi::g0 t] ;#(ltj) - set brc [punk::ansi::g0 u] ;#(rtj) - - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set hltj [punk::ansi::g0 v];#(btj) - } - left_right { - #8 - #from 2 - set tlc [punk::ansi::g0 w] ;#(ttj) - set blc [punk::ansi::g0 v] ;#(btj) - #from3 - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - left_up { - #9 - set tlc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 u] ;#(rtj) - set blc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - right_up { - #10 - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 v] ;#(btj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_left_right { - #11 - set blc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 w] ;#(ttj) - set tlc [punk::ansi::g0 w] ;#(ttj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - down_left_up { - #12 - set tlc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 u] ;#(rtj) - set brc [punk::ansi::g0 u] ;#(rtj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - down_right_up { - #13 - set tlc [punk::ansi::g0 t] ;#(ltj) - set blc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - left_right_up { - #14 - set tlc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 v] ;#(btj) - set brc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_left_right_up { - #15 - set tlc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - } - - - } - "ascii" { - set hl - - set hlt - - set hlb - - set vl | - set vll | - set vlr | - set tlc + - set trc + - set blc + - set brc + - #horizontal and vertical bar joins - #set hltj $hlt - #set hlbj $hlb - #set vllj $vll - #set vlrj $vlr - #ascii + is small - can reasonably be considered a join to anything? - set hltj + - set hlbj + - set vllj + - set vlrj + - #our corners are all + already - so we won't do anything for directions or targets - - } - "light" { - #unicode box drawing set - set hl [punk::char::charshort boxd_lhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_lv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ldr] - set trc [punk::char::charshort boxd_ldl] - set blc [punk::char::charshort boxd_lur] - set brc [punk::char::charshort boxd_lul] - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #15 combos - #sort order: down left right up - #ltj,rtj,ttj,btj e.g left T junction etc. - #Look at from the perspective of a frame/table outline with a clean border and arms pointing inwards - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'light' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - light { - set target$dir light - } - ascii - altg - arc { - set target$dir light - } - heavy { - set target$dir $target - } - default { - set target$dir other - } - } - } - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - heavy { - set blc [punk::char::charshort boxd_dhrul] ;#\u251f down hieavy and right up light (ltj) - set brc \u2527 ;#boxd_dhlul down heavy and left up light (rtj) - set hlbj \u2530 ;# down heavy (ttj) - } - light { - set blc \u251c ;#[punk::char::charshort boxd_lvr] light vertical and right (ltj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set hlbj \u252c ;# (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - heavy { - set tlc \u252d ;# Left Heavy and Right Down Light (ttj) - set blc \u2535 ;# Left Heavy and Right Up Light (btj) - set vllj \u2525 ;# left heavy (rtj) - } - light { - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set vllj \u2524 ;# (rtj) - } - } - } - right { - #3 - switch -- $targetright { - heavy { - set trc \u252e ;#Right Heavy and Left Down Light (ttj) - set brc \u2536 ;#Right Heavy and Left up Light (btj) - set vlrj \u251d;#right heavy (ltj) - } - light { - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set vlrj \u251c;# (ltj) - } - } - } - up { - #4 - switch -- $targetup { - heavy { - set tlc \u251e ;#up heavy (ltj) - set trc \u2526 ;#up heavy (rtj) - } - light { - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - other-light { - set blc \u2534 ;#(btj) - set tlc \u252c ;#(ttj) - #brc - default corner - set vllj \u2524 ;# (rtj) - } - other-other { - #default corners - } - other-heavy { - set blc \u2535 ;# heavy left (btj) - set tlc \u252d ;#heavy left (ttj) - #brc default corner - set vllj \u2525 ;# heavy left (rtj) - } - heavy-light { - set blc \u2541 ;# heavy down (fwj) - set tlc \u252c ;# light (ttj) - set brc \u2527 ;# heavy down (rtj) - set vllj \u2524 ;# (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - heavy-other { - set blc \u251f ;#heavy down (ltj) - #tlc - default corner - set brc \u2527 ;#heavy down (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - heavy-heavy { - set blc \u2545 ;#heavy down and left (fwj) - set tlc \u252d ;#heavy left (ttj) - set brc \u2527 ;#heavy down (rtj) - set vllj \u2525 ;# heavy left (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - light-light { - set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set tlc \u252c ;# boxd_ldhz (ttj) - set brc \u2524 ;# boxd_lvl light vertical and left(rtj) - set vllj \u2524 ;# (rtj) - set hlbj \u252c ;# (ttj) - } - light-other { - set blc \u251c ;# (ltj) - #tlc - default corner - set brc \u2524 ;# boxd_lvl (rtj) - set hlbj \u252c ;# (ttj) - } - light-heavy { - set blc \u253d ;# heavy left (fwj) - set tlc \u252d ;# heavy left (ttj) - set brc \u2524 ;# light (rtj) - set vllj \u2525 ;# heavy left (rtj) - set hlbj \u252c ;# (ttj) - } - default { - set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set tlc \u252c ;# [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc \u2524 ;# [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - } - } - down_right { - #6 - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - down_up { - #7 - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - left_right { - #8 - #from 2 - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - #from3 - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - } - #four way junction (cd::fwj) (punk::ansi::g0 n) (punk::char::charshort lvhz) (+) - } - "heavy" { - #unicode box drawing set - set hl [punk::char::charshort boxd_hhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_hv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_hdr] - set trc [punk::char::charshort boxd_hdl] - set blc [punk::char::charshort boxd_hur] - set brc [punk::char::charshort boxd_hul] - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'heavy' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - heavy { - set target$dir heavy - } - light - ascii - altg - arc { - set target$dir light - } - default { - set target$dir other - } - } - } - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - light { - set blc [punk::char::charshort boxd_dlruh] ;#\u2521 down light and right up heavy (ltj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) - set hlbj \u252F ;#down light (ttj) - } - heavy { - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set hlbj \u2533 ;# down heavy (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - light { - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) - set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) - set vllj \u2528 ;# left light (rtj) - } - heavy { - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set vllj \u252b ;#(rtj) - } - } - } - right { - #3 - switch -- $targetright { - light { - set trc [punk::char::charshort boxd_rlldh] ;#\u2531 Right Light and Left Down Heavy (ttj) - set brc [punk::char::charshort boxd_rlluh] ;#\u2539 Right Light and Left Up Heavy(btj) - set vlrj \u2520 ;#right light (ltj) - } - heavy { - set trc [punk::char::charshort boxd_hdhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set vlrj \u2523 ;# (ltj) - } - } - } - up { - #4 - switch -- $targetup { - light { - set tlc [punk::char::charshort boxd_ulrdh] ;#\u2522 Up Light and Right Down Heavy (ltj) - set trc [punk::char::charshort boxd_ulldh] ;#\u252a Up Light and Left Down Heavy (rtj) - set hltj \u2537 ;# up light (btj) - } - heavy { - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set hltj \u253b ;# (btj) - } - } - } - down_left { - #down_left is the main join type used for 'L' shaped cell border table building where we boxlimit to {vll hlb blc} - #5 - switch -- down-$targetdown-left-$targetleft { - down-light-left-heavy { - set blc [punk::char::charshort boxd_dluhzh] ;#down light and up horizontal heavy (fwj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) (at tlc down stays heavy) - set hlbj \u252F ;# down light (ttj) - set vllj \u252b ;#(rtj) - } - down-heavy-left-light { - set blc [punk::char::charshort boxd_llrvh] ;# left light and right Vertical Heavy (fwj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) (at brc left must stay heavy) - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) - set hlbj \u2533 ;# down heavy (ttj) - set vllj \u2528 ;# left light (rtj) - } - down-light-left-light { - set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) - set hlbj \u252F ;# down light (ttj) - set vllj \u2528 ;# left light (rtj) - } - down-heavy-left-heavy { - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set hlbj \u2533 ;#(ttj) - set vllj \u252b ;#(rtj) - } - down-other-left-heavy { - set blc \u253b ;#boxd_huhz Heavy Up and Horizontal (btj) - #leave brc default corner - set tlc \u2533 ;#hdhz Heavy Down and Horizontal (ttj) - - set vllj \u252b ;#(rtj) - } - down-other-left-light { - set blc \u253a ;#llruh Left Light and Right Up Heavy (btj) - #leave brc default corner - set tlc \u2532 ;#llrdh Left Light and Right Down Heavy (ttj) - - set vllj \u2528 ;# left light (rtj) - } - down-heavy-left-other { - set blc \u2523 ;#hvr Heavy Vertical and Right (ltj) - set brc \u252b ;#hvl Heavy Veritcal and Left (rtj) - #leave tlc default corner - - set hlbj \u2533 ;#(ttj) - } - down-light-left-other { - set blc \u2521 ;#dlruh Down Light and Right Up Heavy (ltj) - set brc \u2529 ;#dlluh Down Light and Left Up Heavy (rtj) - #leave tlc default corner - - set hlbj \u252F ;# down light (ttj) - } - } - } - down_right { - #6 - set blc [punk::char::charshort boxd_hvr] ;# (ltj) (blc right&up stay heavy) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) (tlc down&left stay heavy) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) (brc left&up heavy) - } - down_up { - #7 - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - } - left_right { - #8 - #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - } - } - } - "double" { - #unicode box drawing set - set hl [punk::char::charshort boxd_dhz] ;# double horizontal \U2550 - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551 - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554 - set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557 - set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A - set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - # \u256c (fwj) - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'double' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - double { - set target$dir double - } - light { - set target$dir light - } - default { - set target$dir other - } - } - } - - #unicode provides no joining for double to anything else - #better to leave a gap by using default double corners if join target is not empty or double - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - double { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - set hlbj \u2566 ;# (ttj) - } - light { - set hlbj \u2564 ;# down light (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - double { - set tlc \u2566 ;# (ttj) - set blc \u2569 ;# (btj) - set vllj \u2563 ;# (rtj) - } - light { - set vllj \u2562 ;# light left (rtj) - } - } - } - right { - #3 - switch -- $targetright { - double { - set trc \u2566 ;# (ttj) - set brc \u2569 ;# (btj) - } - light { - set vlrj \u255F ;# light right (ltj) - } - } - } - up { - #4 - switch -- $targetup { - double { - set tlc \u2560 ;# (ltj) - set trc \u2563 ;# (rtj) - set hltj \u2569 ;# (btj) - } - light { - set hltj \u2567 ;#up light (btj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - double-double { - set blc \u256c ;# (fwj) - set brc \u2563 ;# (rtj) - set tlc \u2566 ;# (ttj) - set hlbj \u2566 ;# (ttj) - } - double-light { - #no corner joins treat corners like 'other' - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - - set hlbj \u2566 ;# (ttj) - set vllj \u2562 ;# light left (rtj) - - } - double-other { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - #leave tlc as ordinary double corner - } - light-double { - - set vllj \u2563 ;# (rtj) - set hlbj \u2564 ;# light down (ttj) - - } - light-light { - - set vllj \u2562 ;# light left (rtj) - set hlbj \u2564 ;# light down (ttj) - } - other-light { - set vllj \u2562 ;# light left (rtj) - } - other-double { - set blc \u2569 ;# (btj) - #leave brc as ordinary double corner - set tlc \u2566 ;# (ttj) - } - } - } - down_right { - #6 - switch -- $targetdown-$targetright { - double-double { - set blc \u2560 ;# (ltj) - set trc \u2566 ;# (ttj) - set brc \u256c ;# (fwj) - set hlbj \u2566 ;# (ttj) - } - double-other { - set blc \u2560 ;# (ltj) - #leave trc default - set brc \u2563 ;# (rtj) - } - other-double { - #leave blc default - set trc \u2566 ;# (ttj) - set brc \u2569 ;#(btj) - } - } - } - down_up { - #7 - switch -- $targetdown-$targetup { - double-double { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - set tlc \u2560 ;# (ltj) - set trc \u2563 ;# (rtj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - } - } - left_right { - #8 - - #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set hltj \u2569 ;# (btj) - set vllj \u2563 ;# (rtj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set hltj \u2569 ;# (btj) - set vlrj \u2560 ;# (ltj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set hlbj \u2566 ;# (ttj) - set vlrj \u2560 ;# (ltj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set hltj \u2569 ;# (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - } - - } - "arc" { - #unicode box drawing set - - - set hl [punk::char::charshort boxd_lhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_lv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D - set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E - set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 - set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'arc' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - arc { - set target$dir self - } - default { - set target$dir other - } - } - } - - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - self { - set blc \u251c ;# *light (ltj) - #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left - #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable - #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal - - #set brc \u2524 ;# *light(rtj) - #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) - } - } - } - left { - #2 - switch -- $targetleft { - self { - set tlc \u252c ;# *light(ttj) - need a low positioned curved y shape - nothing apparent - #set blc \u2144 ;# (btj) - upside down y - positioning too low for arc - set blc \u2534 ;# *light (btj) - } - } - } - right { - #3 - switch -- $targetright { - self { - set trc \u252c ;# *light (ttj) - #set brc \u2144 ;# (btj) - set brc \u2534 ;# *light (btj) - } - } - } - up { - #4 - switch -- $targetup { - self { - set tlc \u251c ;# *light (ltj) - set trc \u2524 ;# *light(rtj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - self-self { - #set blc \u27e1 ;# white concave-sided diamond - positioned too far right - #set blc \u27e3 ;# concave sided diamond with rightwards tick - positioned too low, too right - big gaps - set brc \u2524 ;# *light (rtj) - set tlc \u252c ;# *light (ttj) - } - self-other { - #set blc \u2560 ;# (ltj) - #set brc \u2563 ;# (rtj) - #leave tlc as ordinary double corner - } - other-self { - #set blc \u2569 ;# (btj) - #leave brc as ordinary double corner - #set tlc \u2566 ;# (ttj) - } - } - } - } - } - block1 { - #box drawing as far as we can go without extra blocks from legacy computing unicode block - which is unfortunately not commonly supported - set hlt \u2581 ;# lower one eighth block - set hlb \u2594 ;# upper one eighth block - set vll \u258f ;# left one eighth block - set vlr \u2595 ;# right one eighth block - set tlc \u2581 ;# lower one eighth block - set trc \u2581 ;# lower one eighth block - set blc \u2594 ;# upper one eighth block - set brc \u2594 ;# upper one eight block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - } - block2 { - #the resultant table will have text appear towards top of each box - #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps - set hlt \u2594 ;# upper one eighth block - set hlb \u2581 ;# lower one eighth block - set vlr \u2595 ;# right one eighth block - set vll \u258f ;# left one eighth block - - #some terminals (on windows as at 2024) miscount width of these single-width blocks internally - #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) - #This was fixed in windows-terminal based systems (2021) but persists in others. - #https://github.com/microsoft/terminal/issues/11694 - set tlc \U1fb7d ;#legacy block - set trc \U1fb7e ;#legacy block - set blc \U1fb7c ;#legacy block - set brc \U1fb7f ;#legacy block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - } - block2hack { - #the resultant table will have text appear towards top of each box - #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps - set hlt \u2594 ;# upper one eighth block - set hlb \u2581 ;# lower one eighth block - set vlr \u2595 ;# right one eighth block - set vll \u258f ;# left one eighth block - - #see comments in block2 regarding the problems in some terminals that this *may* hack around to some extent. - #the caller probably only needs block2hack if block2 doesn't work - - #1) - #review - this hack looks sort of promising - but overtype::renderline needs fixing ? - #set tlc \U1fb7d\b ;#legacy block - #set trc \U1fb7e\b ;#legacy block - #set blc \U1fb7c\b ;#legacy block - #set brc \U1fb7f\b ;#legacy block - - #2) - works on cmd.exe and some others - # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones - #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) - #this hack has a reasonable chance of working - #except that the punk overtype library does recognise PMs - #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! - #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. - set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block - set trc \U1fb7e\x1b^\b\x1b\\ ;#legacy block - set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block - set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - } - block { - set hlt \u2580 ;#upper half - set hlb \u2584 ;#lower half - set vll \u258c ;#left half - set vlr \u2590 ;#right half - - set tlc \u259b ;#upper left corner half - set trc \u259c - set blc \u2599 - set brc \u259f - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - } - default { - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing - if {[llength $f] % 2 != 0} { - #todo - retrieve usage from punk::args - error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $::textblock::frametypes and does not appear to be a dictionary for a custom frametype" - } - #unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults - dict for {k v} $f { - switch -- $k { - hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} - default { - error "textblock::frametype '$f' has unknown element '$k'" - } - } - } - #verified keys - safe to extract as vars - set custom_frame [tcl::dict::merge $default_custom $f] - tcl::dict::with custom_frame {} ;#extract keys as vars - #longer j vars must be after their more specific counterparts in the list being processed by foreach - foreach t {hlt hlb vll vlr hltj hlbj vllj vlrj} { - if {[tcl::dict::exists $custom_frame $t]} { - set $t [tcl::dict::get $custom_frame $t] - } else { - #set more explicit type to it's more general counterpart if it's missing - #e.g hlt -> hl - #e.g hltj -> hlt - set $t [set [string range $t 0 end-1]] - } - } - #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set - #horizontal and vertical bar joins - key/variable ends with 'j' - } - } - if {$boxonly} { - set result [tcl::dict::create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - ] - tcl::dict::set framedef_cache $cache_key $result - return $result - } else { - set result [tcl::dict::create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - hltj $hltj\ - hlbj $hlbj\ - vllj $vllj\ - vlrj $vlrj\ - ] - tcl::dict::set framedef_cache $cache_key $result - return $result - } - } - - variable frame_cache - set frame_cache [tcl::dict::create] - proc frame_cache {args} { - set argd [punk::args::get_dict { - -action -default "" -choices {clear} -help "Clear the textblock::frame_cache dictionary" - -pretty -default 1 -help "Use 'pdict textblock::frame_cache */*' for prettier output" - *values -min 0 -max 0 - } $args] - set action [dict get $argd opts -action] - - if {$action ni [list clear ""]} { - error "frame_cache action '$action' not understood. Valid actions: clear" - } - variable frame_cache - if {[dict get $argd opts -pretty]} { - set out [pdict -chan none frame_cache */*] - } else { - set out "" - if {[catch { - set termwidth [tcl::dict::get [punk::console::get_size] columns] - }]} { - set termwidth 80 - } - - tcl::dict::for {k v} $frame_cache { - lassign $v _f frame _used used - set fwidth [textblock::widthtopline $frame] - #review - are cached frames uniform width lines? - #set fwidth [textblock::width $frame] - set frameinfo "$k used:$used " - set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] - if {$allinone_width >= $termwidth} { - #split across 2 lines - append out "$frameinfo\n" - append out $frame \n - } else { - append out [textblock::join -- $frameinfo $frame]\n - } - append out \n ;# frames used to build tables often have joins - keep a line in between for clarity - } - } - if {$action eq "clear"} { - set frame_cache [tcl::dict::create] - append out \nCLEARED - } - return $out - } - - - #options before content argument - which is allowed to be absent - #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. - # - #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) - # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? - #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand - #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it - # - but we would need to maintain support for the rendered-string based operations too. - proc frame {args} { - variable frametypes - variable use_md5 - - #counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var - set opts [tcl::dict::create\ - -etabs 0\ - -type light\ - -boxlimits [list hl vl tlc blc trc brc]\ - -boxmap {}\ - -joins [list]\ - -title ""\ - -subtitle ""\ - -width ""\ - -height ""\ - -ansiborder ""\ - -ansibase ""\ - -blockalign "centre"\ - -textalign "left"\ - -ellipsis 1\ - -usecache 1\ - -buildcache 1\ - -pad 1\ - -crm_mode 0\ - ] - #-pad 1 is default so that simple 'textblock::frame "[a+ Red]a \nbbb[a]" extends the bg colour on the short ragged lines (and empty lines) - # for ansi art - -pad 0 is likely to be preferable - - set expect_optval 0 - set argposn 0 - set pmax [expr {[llength $args]-1}] - set has_contents 0 ;#differentiate between empty string and no content supplied - set contents "" - set arglist [list] - foreach a $args { - if {!$expect_optval} { - if {$argposn < $pmax} { - if {[tcl::string::match -* $a]} { - set expect_optval 1 - lappend arglist $a - } else { - error "textblock::frame expects -option pairs" - } - } else { - set has_contents 1 - set contents $a - } - } else { - lappend arglist $a - set expect_optval 0 - } - incr argposn - } - - #set contents [lindex $args end] - #set arglist [lrange $args 0 end-1] - if {[llength $arglist] % 2 != 0} { - error "Usage frame ?-type unicode|altg|ascii|? ?-title ? ?-subtitle ? ?-width ? ?-ansiborder ? ?-boxlimits hl|hlt|hlb|vl|vll|vlr|tlc|blc|brc? ?-joins left|right|up|down? " - } - #todo args -justify left|centre|right (center) - - #todo -blockalignbias -textalignbias? - #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache - foreach {k v} $arglist { - switch -- $k { - -etabs - -type - -boxlimits - -boxmap - -joins - - -title - -subtitle - -width - -height - - -ansiborder - -ansibase - - -blockalign - -textalign - -ellipsis - - -crm_mode - - -usecache - -buildcache - -pad { - tcl::dict::set opts $k $v - } - default { - error "frame option '$k' not understood. Valid options are [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- - set opt_etabs [tcl::dict::get $opts -etabs] - set opt_type [tcl::dict::get $opts -type] - set opt_boxlimits [tcl::dict::get $opts -boxlimits] - set opt_joins [tcl::dict::get $opts -joins] - set opt_boxmap [tcl::dict::get $opts -boxmap] - set opt_usecache [tcl::dict::get $opts -usecache] - set opt_buildcache [tcl::dict::get $opts -buildcache] - set opt_pad [tcl::dict::get $opts -pad] - set opt_crm_mode [tcl::dict::get $opts -crm_mode] - set usecache $opt_usecache ;#may need to override - set buildcache $opt_buildcache - set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - - set known_frametypes $frametypes ;# light, heavey etc as defined in the ::textblock::frametypes variable - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - - lassign [textblock::frametype $opt_type] _cat category _type ftype - if {$category eq "custom"} { - set custom_frame $ftype - set frameset "custom" - set framedef $custom_frame - } else { - #category = predefined - set frameset $ftype ;# light,heavy etc - set framedef $ftype - } - - set is_boxlimits_ok 1 - set exact_boxlimits [list] - foreach v $opt_boxlimits { - switch -- $v { - hl { - lappend exact_boxlimits hlt hlb - } - vl { - lappend exact_boxlimits vll vlr - } - hlt - hlb - vll - vlr - tlc - trc - blc - brc { - lappend exact_boxlimits $v - } - default { - #k not in custom_keys - set is_boxlimits_ok 0 - break - } - } - } - if {!$is_boxlimits_ok} { - error "frame option -boxlimits '$opt_boxlimits' must contain only values from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - set exact_boxlimits [lsort -unique $exact_boxlimits] - - set is_joins_ok 1 - foreach v $opt_joins { - lassign [split $v -] direction target - switch -- $direction { - left - right - up - down {} - default { - set is_joins_ok 0 - break - } - } - switch -- $target { - "" - light - heavy - ascii - altg - arc - double - custom - block - block1 - block2 {} - default { - set is_joins_ok 0 - break - } - } - } - if {!$is_joins_ok} { - error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" - } - set is_boxmap_ok 1 - #safe jumptable test - #dict for {boxelement subst} $opt_boxmap {} - tcl::dict::for {boxelement subst} $opt_boxmap { - switch -- $boxelement { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - default { - set is_boxmap_ok 0 - break - } - } - } - if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - - #sorted order down left right up - #1 x choose 4 - #4 x choose 3 - #6 x choose 2 - #4 x choose 1 - #15 combos - - set join_directions [list] - #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode - #e.g down-light, up-heavy - set join_targets [tcl::dict::create left "" down "" right "" up ""] - foreach jt $opt_joins { - lassign [split $jt -] direction target - if {$target ne ""} { - tcl::dict::set join_targets $direction $target - } - lappend join_directions $direction - } - set join_directions [lsort -unique $join_directions] - set do_joins [::join $join_directions _] - - - # -- --- --- --- --- --- - set opt_title [tcl::dict::get $opts -title] - set opt_subtitle [tcl::dict::get $opts -subtitle] - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - # -- --- --- --- --- --- - set opt_blockalign [tcl::dict::get $opts -blockalign] - switch -- $opt_blockalign { - left - right - centre - center {} - default { - error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign" - } - } - #these are all valid commands for overtype:: - # -- --- --- --- --- --- - set opt_textalign [tcl::dict::get $opts -textalign] - switch -- $opt_textalign { - left - right - centre - center {} - default { - error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" - } - } - # -- --- --- --- --- --- - - set opt_ansiborder [tcl::dict::get $opts -ansiborder] - set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - # -- --- --- --- --- --- - - if {$has_contents} { - if {[tcl::string::last \t $contents] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - if {$opt_etabs} { - set contents [textutil::tabify::untabify2 $contents $tw] - } - } - set contents [tcl::string::map [list \r\n \n] $contents] - if {$opt_crm_mode} { - if {$opt_height eq ""} { - set h [textblock::height $contents] - } else { - set h [expr {$opt_height -2}] - } - if {$opt_width eq ""} { - set w [textblock::width $contents] - } else { - set w [expr {$opt_width -2}] - } - set contents [overtype::renderspace -crm_mode 1 -wrap 1 -width $w -height $h "" $contents] - } - set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) - set actual_contentheight [textblock::height $contents] - } else { - set actual_contentwidth 0 - set actual_contentheight 0 - } - - if {$opt_title ne ""} { - set titlewidth [punk::ansi::printing_length $opt_title] - set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}] - } else { - set titlewith 0 - set content_or_title_width $actual_contentwidth - } - - if {$opt_width eq ""} { - set frame_inner_width $content_or_title_width - } else { - set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default - } - - if {$opt_height eq ""} { - set frame_inner_height $actual_contentheight - } else { - set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default - } - if {$frame_inner_height == 0 && $frame_inner_width == 0} { - set has_contents 0 - } - #todo - render it with vertical overflow so we can process ansi moves? - #set linecount [textblock::height $contents] - set linecount $frame_inner_height - - # -- --- --- --- --- --- --- --- --- - variable frame_cache - #review - custom frame affects frame_inner_width - exclude from caching? - #set cache_key [concat $arglist $frame_inner_width $frame_inner_height] - set hashables [concat $arglist $frame_inner_width $frame_inner_height] - - if {$use_md5} { - #package require md5 ;#already required at package load - if {[package vsatisfies [package present md5] 2- ] } { - set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review - } else { - set hash [md5::md5 [encoding convertto utf-8 $hashables]] - } - } else { - set hash $hashables - } - - set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth" - #should be in a unicode private range different to that used in table construction - #e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts - #also supplementary private use blocks - #however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult) - #U+F0000 -> U+FFFD - #U+100000 -> U+10FFFD - #FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy) - #should be something someone is unlikely to use as part of a custom frame character. - #ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better) - #As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string - #terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like. - #e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never" - #review - we could consider wasting a few cycles to check for a conflict and use a different FSUB - set FSUB \uF2DD - - - #this occurs commonly in table building with colspans - review - if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { - set usecache 0 - #set buildcache 0 ;#comment out for debug/analysis so we can see - #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" - set cache_key [a+ Web-red web-white]$cache_key[a] - } - if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { - #colourise cache_key to warn - if {$actual_contentwidth == 0} { - #we can still substitute with right length - set cache_key [a+ Web-steelblue web-black]$cache_key[a] - } else { - #actual_contentwidth is narrower than frame - check template's patternwidth - if {[tcl::dict::exists $frame_cache $cache_key]} { - set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] - } else { - set cache_patternwidth $actual_contentwidth - } - if {$actual_contentwidth < $cache_patternwidth} { - set usecache 0 - set cache_key [a+ Web-orange web-black]$cache_key[a] - } elseif {$actual_contentwidth == $cache_patternwidth} { - #set usecache 1 - } else { - #actual_contentwidth > pattern - set usecache 0 - set cache_key [a+ Web-red web-black]$cache_key[a] - } - } - } - - #JMN debug - #set usecache 0 - - set is_cached 0 - if {$usecache && [tcl::dict::exists $frame_cache $cache_key]} { - set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] - set template [tcl::dict::get $frame_cache $cache_key frame] - set used [tcl::dict::get $frame_cache $cache_key used] - tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record - set is_cached 1 - - } - - # -- --- --- --- --- --- --- --- --- - if {!$is_cached} { - set rst [a] - #set column [tcl::string::repeat " " $frame_inner_width] ;#default - may need to override for custom frame - set underlayline [tcl::string::repeat " " $frame_inner_width] - set underlay [::join [lrepeat $linecount $underlayline] \n] - - - set vll_width 1 ;#default for all except custom (printing width) - set vlr_width 1 - - set framedef [textblock::framedef -joins $opt_joins $framedef] - tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars - - #puts "---> $opt_boxmap" - #review - we handle double-wide in custom frames - what about for boxmaps? - tcl::dict::for {boxelement sub} $opt_boxmap { - if {$boxelement eq "vl"} { - set vll $sub - set vlr $sub - set hl $sub - } elseif {$boxelement eq "hl"} { - set hlt $sub - set hlb $sub - set hl $sub - } else { - set $boxelement $sub - } - } - - switch -- $frameset { - custom { - #REVIEW - textblock::table assumes that at least the vl elements are 1-wide - #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though - #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely - set vll_width [punk::ansi::printing_length $vll] - set hlb_width [punk::ansi::printing_length $hlb] - set hlt_width [punk::ansi::printing_length $hlt] - - set vlr_width [punk::ansi::printing_length $vlr] - - set tlc_width [punk::ansi::printing_length $tlc] - set trc_width [punk::ansi::printing_length $trc] - set blc_width [punk::ansi::printing_length $blc] - set brc_width [punk::ansi::printing_length $brc] - - - set framewidth [expr {$frame_inner_width + 2}] ;#reverse default assumption - if {$opt_width eq ""} { - #width wasn't specified - so user is expecting frame to adapt to title/contents - #content shouldn't truncate because of extra wide frame - #review - punk::console::get_size ? wrapping? quite hard to support with colspans - set frame_inner_width $content_or_title_width - set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width - set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] - } else { - set frame_inner_width [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated - set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}] - set bbarwidth [expr {$opt_width - $blc_width - $brc_width}] - } - #set column [tcl::string::repeat " " $frame_inner_width] - set underlayline [tcl::string::repeat " " $frame_inner_width] - set underlay [::join [lrepeat $linecount $underlayline] \n] - #cache? - - if {$hlt_width == 1} { - set tbar [tcl::string::repeat $hlt $tbarwidth] - } else { - #possibly mixed width chars that make up hlt - tcl::string::range won't get width right - set blank [tcl::string::repeat " " $tbarwidth] - if {$hlt_width > 0} { - set count [expr {($tbarwidth / $hlt_width) + 1}] - } else { - set count 0 - } - set tbar [tcl::string::repeat $hlt $count] - #set tbar [tcl::string::range $tbar 0 $tbarwidth-1] - set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character - } - if {$hlb_width == 1} { - set bbar [tcl::string::repeat $hlb $bbarwidth] - } else { - set blank [tcl::string::repeat " " $bbarwidth] - if {$hlb_width > 0} { - set count [expr {($bbarwidth / $hlb_width) + 1}] - } else { - set count 0 - } - set bbar [tcl::string::repeat $hlb $count] - #set bbar [tcl::string::range $bbar 0 $bbarwidth-1] - set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] - } - } - altg { - set tbar [tcl::string::repeat $hlt $frame_inner_width] - set tbar [cd::groptim $tbar] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - set bbar [cd::groptim $bbar] - } - default { - set tbar [tcl::string::repeat $hlt $frame_inner_width] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - - } - } - - set leftborder 0 - set rightborder 0 - set topborder 0 - set bottomborder 0 - # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - #puts "----->$exact_boxlimits" - foreach lim $exact_boxlimits { - switch -- $lim { - hlt { - set topborder 1 - } - hlb { - set bottomborder 1 - } - vll { - set leftborder 1 - } - vlr { - set rightborder 1 - } - tlc { - set topborder 1 - set leftborder 1 - } - trc { - set topborder 1 - set rightborder 1 - } - blc { - set bottomborder 1 - set leftborder 1 - } - brc { - set bottomborder 1 - set rightborder 1 - } - } - } - if {$opt_width ne "" && $opt_width < 2} { - set rightborder 0 - } - #keep lhs/rhs separate? can we do vertical text on sidebars? - set lhs [tcl::string::repeat $vll\n $linecount] - set lhs [tcl::string::range $lhs 0 end-1] - set rhs [tcl::string::repeat $vlr\n $linecount] - set rhs [tcl::string::range $rhs 0 end-1] - - - if {$opt_ansiborder ne ""} { - set tbar $opt_ansiborder$tbar$rst - set bbar $opt_ansiborder$bbar$rst - set tlc $opt_ansiborder$tlc$rst - set trc $opt_ansiborder$trc$rst - set blc $opt_ansiborder$blc$rst - set brc $opt_ansiborder$brc$rst - - set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out - set rhs $opt_ansiborder$rhs$rst - } - - #boxlimits used for partial borders in table generation - set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] - set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] - foreach lim $unspecified_limits { - switch -- $lim { - vll { - set blank_vll [tcl::string::repeat " " $vll_width] - set lhs [tcl::string::repeat $blank_vll\n $linecount] - set lhs [tcl::string::range $lhs 0 end-1] - } - vlr { - set blank_vlr [tcl::string::repeat " " $vlr_width] - set rhs [tcl::string::repeat $blank_vlr\n $linecount] - set rhs [tcl::string::range $rhs 0 end-1] - } - hlt { - set bar_width [punk::ansi::printing_length $tbar] - set tbar [tcl::string::repeat " " $bar_width] - } - tlc { - set tlc_width [punk::ansi::printing_length $tlc] - set tlc [tcl::string::repeat " " $tlc_width] - } - trc { - set trc_width [punk::ansi::printing_length $trc] - set trc [tcl::string::repeat " " $trc_width] - } - hlb { - set bar_width [punk::ansi::printing_length $bbar] - set bbar [tcl::string::repeat " " $bar_width] - } - blc { - set blc_width [punk::ansi::printing_length $blc] - set blc [tcl::string::repeat " " $blc_width] - } - brc { - set brc_width [punk::ansi::printing_length $brc] - set brc [tcl::string::repeat " " $brc_width] - } - } - } - - if {$opt_title ne ""} { - set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off - } else { - set topbar $tbar - } - if {$opt_subtitle ne ""} { - set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off - } else { - set bottombar $bbar - } - if {$opt_ansibase eq ""} { - set rstbase [a] - } else { - set rstbase [a]$opt_ansibase - } - - if {$opt_title ne ""} { - #title overrides -boxlimits for topborder - set topborder 1 - } - set fs "" - set fscached "" - set cache_patternwidth 0 - #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? - if {$topborder} { - if {$leftborder && $rightborder} { - append fs $tlc$topbar$trc - } else { - if {$leftborder} { - append fs $tlc$topbar - } elseif {$rightborder} { - append fs $topbar$trc - } else { - append fs $topbar - } - } - } - append fscached $fs - if {$has_contents || $opt_height > 2} { - #if {$topborder && $fs ne "xx"} { - # append fs \n - #} - if {$topborder} { - append fs \n - append fscached \n - } - switch -- $opt_textalign { - right {set pad "left"} - left {set pad "right"} - default {set pad $opt_textalign} - } - #set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1] - #set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents] - - set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth] - set cache_patternwidth $actual_contentwidth - set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] - set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] - #after overtype::block - our actual patternwidth may be less - set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] - - if {$leftborder && $rightborder} { - #set bodyparts [list $lhs $inner $rhs] - set cache_bodyparts [list $lhs $cache_inner $rhs] - } else { - if {$leftborder} { - #set bodyparts [list $lhs $inner] - set cache_bodyparts [list $lhs $cache_inner] - } elseif {$rightborder} { - #set bodyparts [list $inner $rhs] - set cache_bodyparts [list $cache_inner $rhs] - } else { - #set bodyparts [list $inner] - set cache_bodyparts [list $cache_inner] - } - } - #set body [textblock::join -- {*}$bodyparts] - set cache_body [textblock::join -- {*}$cache_bodyparts] - append fscached $cache_body - #append fs $body - } - - if {$opt_height eq "" || $opt_height > 1} { - if {$opt_subtitle ne ""} { - #subtitle overrides boxlimits for bottomborder - set bottomborder 1 - } - if {$bottomborder} { - if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { - #append fs \n - append fscached \n - } - if {$leftborder && $rightborder} { - #append fs $blc$bottombar$brc - append fscached $blc$bottombar$brc - } else { - if {$leftborder} { - #append fs $blc$bottombar - append fscached $blc$bottombar - } elseif {$rightborder} { - #append fs $bottombar$brc - append fscached $bottombar$brc - } else { - #append fs $bottombar - append fscached $bottombar - } - } - } - } - set template $fscached - ;#end !$is_cached - } - - #use the same mechanism to build the final frame - whether from cache or template - if {$actual_contentwidth == 0} { - set fs [tcl::string::map [list $FSUB " "] $template] - } else { - set resultlines [list] - set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] - set contentindex 0 - switch -- $opt_textalign { - left {set pad right} - right {set pad left} - default {set pad $opt_textalign} - } - - #review - if {[tcl::string::is integer -strict $opt_height] && $actual_contentheight < ($opt_height -2)} { - set diff [expr {($opt_height -2) - $actual_contentheight}] - append contents [::join [lrepeat $diff \n] ""] - } - - if {$opt_pad} { - set paddedcontents [textblock::pad $contents -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) - set paddedwidth [textblock::widthtopline $paddedcontents] - #review - horizontal truncation - if {$paddedwidth > $cache_patternwidth} { - set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] - } - #important to supply end of opts -- to textblock::join - particularly here with arbitrary data - set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays - } else { - set cwidth [textblock::width $contents] - if {$cwidth > $cache_patternwidth} { - set contents [overtype::renderspace -width $cache_patternwidth "" $contents] - } - set contentblock [textblock::join -- $contents] - } - - set tlines [split $template \n] - - #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. - #after textblock::join the reset will be a separate code ie should be exactly ESC[0m - set R [a] - set rlen [tcl::string::length $R] - set clines [split $contentblock \n] - - foreach tline $tlines { - if {[tcl::string::first $FSUB $tline] >= 0} { - set content_line [lindex $clines $contentindex] - if {[tcl::string::first $R $content_line] == 0} { - set content_line [tcl::string::range $content_line $rlen end] - } - #make sure to replay opt_ansibase to the right of the replacement - lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline] - incr contentindex - } else { - lappend resultlines $tline - } - } - set fs [::join $resultlines \n] - } - - - if {$is_cached} { - return $fs - } else { - if {$buildcache} { - tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] - } - return $fs - } - } - proc gcross {args} { - set argd [punk::args::get_dict { - -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block - Only cross sizes that divide the size of the overall block will be used. - e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. - Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) - If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. - " - *values -min 1 - size -default 1 -type integer - } $args] - set size [dict get $argd values size] - set opts [dict get $argd opts] - - if {$size == 0} { - return "" - } - - set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] - - #set fit_size [punk::lib::greatestOddFactor $size] - set fit_size $size - if {$opt_max_cross_size == 0} { - set max_cross_size $fit_size - } else { - #todo - only allow divisors - #set testsize [expr {min($fit_size,$opt_max_cross_size)}] - - set factors [punk::lib::factors $size] - #pick odd size in list that is smaller or equal to test_size - set max_cross_size [lindex $factors end] - set last_ok [lindex $factors 0] - for {set i 0} {$i < [llength $factors]} {incr i} { - set s [lindex $factors $i] - if {$s > $opt_max_cross_size} { - break - } - set last_ok $s - } - set max_cross_size $last_ok - } - set crosscount [expr {$size / $max_cross_size}] - - package require punk::char - set x [punk::char::charshort boxd_ldc] - set bs [punk::char::charshort boxd_ldgullr] - set fs [punk::char::charshort boxd_ldgurll] - - set onecross "" - set crossrows [list] - set armsize [expr {int(floor($max_cross_size /2))}] - set row [lrepeat $max_cross_size " "] - #toparm - for {set i 0} {$i < $armsize} {incr i} { - set r $row - lset r $i $bs - lset r end-$i $fs - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - - if {$max_cross_size % 2 != 0} { - #only put centre cross in for odd sized crosses - set r $row - lset r $armsize $x - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - - for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} { - set r $row - lset r $i $fs - lset r end-$i $bs - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - #set onecross [tcl::string::trimright $onecross \n] - set onecross [::join $crossrows \n] - - #fastest to do row first then columns - because textblock::join must do line by line - - if {$crosscount > 1} { - set row [textblock::join -- {*}[lrepeat $crosscount $onecross]] - set rows [lrepeat $crosscount $row] - set out [::join $rows \n] - } else { - set out $onecross - } - - return $out - } - - #Test we can join two coloured blocks - proc test_colour {} { - set b1 [a red]1\n2\n3[a] - set b2 [a green]a\nb\nc[a] - set result [textblock::join -- $b1 $b2] - puts $result - #return [list $b1 $b2 $result] - return [ansistring VIEW $result] - } - tcl::namespace::import ::punk::ansi::ansistrip -} - - -tcl::namespace::eval ::textblock::piper { - tcl::namespace::export * - proc join {rhs pipelinedata} { - tailcall ::textblock::join -- $pipelinedata $rhs - } -} -interp alias {} piper_blockjoin {} ::textblock::piper::join - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide textblock [tcl::namespace::eval textblock { - variable version - set version 0.1.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.2.tm index 9270ca9c..c7da645b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.2.tm @@ -185,6 +185,8 @@ namespace eval tomlish { error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" } ITABLE { + #This one should not be returned as a type value structure! + # set result [::tomlish::to_dict [list $found_sub]] } ARRAY { @@ -249,6 +251,7 @@ namespace eval tomlish { } + #to_dict is a *basic* programmatic datastructure for accessing the data. # produce a dictionary of keys and values from a tomlish tagged list. # to_dict is primarily for reading toml data. @@ -271,8 +274,12 @@ namespace eval tomlish { # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. #we don't error out just because a previous tablename segment has already appeared. - variable tablenames_seen [list] - + ##variable tablenames_seen [list] + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] + } log::info ">>> processing '$tomlish'<<<" set items $tomlish @@ -311,9 +318,9 @@ namespace eval tomlish { } DOTTEDKEY { log::debug "--> processing $tag: $item" - set dkey_info [_get_dottedkey_info $item] - set dotted_key_hierarchy [dict get $dkey_info keys] - set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] + set dkey_info [_get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] #a.b.c = 1 #table_key_hierarchy -> a b @@ -345,6 +352,9 @@ namespace eval tomlish { set keyval_dict [_get_keyval_value $item] dict set datastructure {*}$pathkeys $leafkey $keyval_dict + + #JMN test 2025 + } TABLE { set tablename [lindex $item 1] @@ -386,8 +396,40 @@ namespace eval tomlish { lappend table_key_hierarchy_raw $rawseg if {[dict exists $datastructure {*}$table_key_hierarchy]} { - #It's ok for this key to already exist *if* it was defined by a previous tablename, - # but not if it was defined as a key/qkey/skey ? + #It's ok for this key to already exist *if* it was defined by a previous tablename or equivalent + #and if this key is longer + + #consider the following 2 which are legal: + #[table] + #x.y = 3 + #[table.x.z] + #k= 22 + + #equivalent + + #[table] + #[table.x] + #y = 3 + #[table.x.z] + #k=22 + + #illegal + #[table] + #x.y = 3 + #[table.x.y.z] + #k = 22 + ## - we should bfail on encoungerint table.x.y because only table and table.x are effectively tables + ## - we should also fail if + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + + #TODO! fix - this code is wrong set testkey [join $table_key_hierarchy_raw .] @@ -422,7 +464,7 @@ namespace eval tomlish { if {$found_testkey == 0} { #the raw table_key_hierarchy is better to display in the error message, although it's not the actual dict keyset set msg "key [join $table_key_hierarchy_raw .] already exists in datastructure, but wasn't defined by a supertable." - append msg "tablenames_seen:" + append msg \n "tablenames_seen:" \n foreach ts $tablenames_seen { append msg " " $ts \n } @@ -453,13 +495,18 @@ namespace eval tomlish { #now add the contained elements foreach element [lrange $item 2 end] { set type [lindex $element 0] + log::debug "--> $type processing contained element $element" switch -exact -- $type { DOTTEDKEY { set dkey_info [_get_dottedkey_info $element] - set dotted_key_hierarchy [dict get $dkey_info keys] - set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] - set leaf_key [lindex $dotted_key_hierarchy end] - set dkeys [lrange $dotted_key_hierarchy 0 end-1] + #e.g1 keys {x.y y} keys_raw {'x.y' y} + #e.g2 keys {x.y y} keys_raw {{"x.y"} y} + set dotted_key_hierarchy [dict get $dkey_info keys] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + set leaf_key [lindex $dotted_key_hierarchy end] + set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] + set dkeys_raw [lrange $dotted_key_hierarchy_raw 0 end-1] + set leaf_key_raw [lindex $dotted_key_hierarchy_raw end] #ensure empty keys are still represented in the datastructure set test_keys $table_keys @@ -476,7 +523,22 @@ namespace eval tomlish { error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." } set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout ">>> $keyval_dict" dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + #JMN 2025 + #tomlish::utils::normalize_key ?? + lappend tablenames_seen [join [list {*}$table_key_hierarchy_raw {*}$dkeys_raw] .] ;#???? + #if the keyval_dict is not a simple type x value y - then it's an inline table ? + #if so - we should add the path to the leaf_key as a seen table too - as it's not allowed to have more entries added. + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + lappend tablenames_seen [join [list {*}$table_key_hierarchy_raw {*}$dkeys_raw $leaf_key_raw] .] + } + } KEY - QKEY - SQKEY { #obsolete ? @@ -777,7 +839,7 @@ namespace eval tomlish { set result [list] set lastparent [lindex $parents end] if {$lastparent in [list "" do_inline]} { - if {[tomlish::dict::is_tomltype $vinfo]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { set type [dict get $vinfo type] #treat ITABLE differently? set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] @@ -811,7 +873,7 @@ namespace eval tomlish { } else { set VK_PART [list KEY $vk] } - if {[tomlish::dict::is_tomltype $vv]} { + if {[tomlish::dict::is_tomlish_typeval $vv]} { #type x value y set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] @@ -877,7 +939,7 @@ namespace eval tomlish { } } else { #lastparent is not toplevel "" or "do_inline" - if {[tomlish::dict::is_tomltype $vinfo]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { #type x value y set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] lappend result {*}$sublist @@ -901,7 +963,7 @@ namespace eval tomlish { } else { set VK_PART [list KEY $vk] } - if {[tomlish::dict::is_tomltype $vv]} { + if {[tomlish::dict::is_tomlish_typeval $vv]} { #type x value y set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] set record [list DOTTEDKEY [list $VK_PART] = $sublist] @@ -2404,7 +2466,8 @@ namespace eval tomlish::utils { } ;#RS #check if str is valid for use as a toml bare key - proc is_barekey {str} { + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { if {[tcl::string::length $str] == 0} { return 0 } else { @@ -2418,6 +2481,52 @@ namespace eval tomlish::utils { } } + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + #test only that the characters in str are valid for the toml specified type 'integer'. proc int_validchars1 {str} { set numchars [tcl::string::length $str] @@ -3471,7 +3580,7 @@ namespace eval tomlish::parse { return 1 } barekey { - error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z_-\] allowed. [tomlish::parse::report_line]" + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" } whitespace { # hash marks end of whitespace token @@ -5222,7 +5331,7 @@ namespace eval tomlish::parse { if {[tomlish::utils::is_barekey $c]} { append tok $c } else { - error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] allowed. [tomlish::parse::report_line]" + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" } } starttablename - starttablearrayname { @@ -5354,10 +5463,15 @@ namespace eval tomlish::dict { namespace export {[a-z]*}; # Convention: export all lowercase namespace path [namespace parent] - proc is_tomltype {d} { - expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value]} + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} } - proc is_tomltype2 {d} { + proc is_tomlish_typeval2 {d} { upvar ::tomlish::tags tags expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} } @@ -5366,7 +5480,7 @@ namespace eval tomlish::dict { set dictposn [expr {[dict size $d] -1}] foreach k [lreverse [dict keys $d]] { set dval [dict get $d $k] - if {[is_tomltype $dval]} { + if {[is_tomlish_typeval $dval]} { set last_simple $dictposn break } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.3.tm new file mode 100644 index 00000000..3da39427 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.3.tm @@ -0,0 +1,6002 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application tomlish 1.1.3 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin tomlish_module_tomlish 0 1.1.3] +#[copyright "2024"] +#[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] +#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] +#[require tomlish] +#[keywords module parsing toml configuration] +#[description] +#[para] tomlish is an intermediate representation of toml data in a tree structure (tagged lists representing type information) +#[para] The design goals are for tomlish to be whitespace and comment preserving ie byte-for byte preservation during roundtrips from toml to tomlish and back to toml +#[para] The tomlish representation can then be converted to a Tcl dict structure or to other formats such as json, +#[para] although these other formats are generally unlikely to retain whitespace or comments +#[para] The other formats also won't preserve roundtripability e.g \t and a literal tab coming from a toml file will be indistinguishable. +#[para] A further goal is to allow at least a useful subset of in-place editing operations which also preserve whitespace and comments. +#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions +#[para] The API for editing (tomldoc object?) may require explicit setting of type if accessing an existing key +#[para] e.g setting a key that already exists and is a different type (especially if nested structure such as a table or array) +#[para] will need a -type option (-force ?) to force overriding with another type such as an int. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of tomlish +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by tomlish +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::stack +package require logger + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {struct::stack}] + +#limit ourselves to clear, destroy, peek, pop, push, rotate, or size (e.g v 1.3 does not implement 'get') + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish { + namespace export {[a-z]*}; # Convention: export all lowercase + variable types + + #IDEAS: + # since get_toml produces tomlish with whitespace/comments intact: + # tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace + # - setKey (set leaf only to value) how to specify type? -type option? - whole array vs index into arrays and further nested objects? - option for raw toml additions? + # - separate addKey?? + # - deleteKey (delete leaf) + # - deleteTable (delete table - if only has leaves? - option to delete with child tables?) + # - set/add Table? - position in doc based on existing tables/subtables? + + #The tomlish intermediate representation allows things such as sorting the toml document by table name or other re-ordering of tables - + # because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. + #The same goes for the first newline following a keyval e.g x=1 \ny=2\n\n + #The newline is part of the keyval structure so makes reordering easier + #example from_toml "a=1\nb=2\n\n\n" + # 0 = TOMLISH + # 1 = KEY a = {INT 1} {NEWLINE lf} + # 2 = NEWLINE lf + # 3 = KEY b = {INT 2} {NEWLINE lf} + # 4 = NEWLINE lf + # 5 = NEWLINE lf + + + #ARRAY is analogous to a Tcl list + #TABLE is analogous to a Tcl dict + #WS = inline whitespace + #KEY = bare key and value + #DQKEY = double quoted key and value + #SQKEY = single quoted key and value + #ITABLE = inline table (*can* be anonymous table) + # inline table values immediately create a table with the opening brace + # inline tables are fully defined between their braces, as are dotted-key subtables defined within + # No additional subtables or arrays of tables may be defined within an inline table after the ending brace - they must be entirely self-contained + + set tags [list TOMLISH ARRAY TABLE ITABLE ANONTABLE WS NEWLINE COMMENT DOTTEDKEY KEY DQKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME] + #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) + #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) + set min_int -9223372036854775808 ;#-2^63 + set max_int +9223372036854775807 ;#2^63-1 + + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] tomlish '$txt'" + puts stderr $msg + } + logger::initNamespace ::tomlish + foreach lvl [logger::levels] { + interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl + log::logproc $lvl tomlish_log_$lvl + } + + #*** !doctools + #[subsection {Namespace tomlish}] + #[para] Core API functions for tomlish + #[list_begin definitions] + + proc tags {} { + return $::tomlish::tags + } + + #helper function for to_dict + proc _get_keyval_value {keyval_element} { + log::notice ">>> _get_keyval_value from '$keyval_element'<<<" + set found_value 0 + #find the value + # 3 is the earliest index at which the value could occur (depending on whitespace) + set found_sub [list] + if {[lindex $keyval_element 2] ne "="} { + error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured { = } list" + } + + #review + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] ;#list of lists + } + if {[uplevel 1 [list info exists tablenames_closed]]} { + upvar tablenames_closed tablenames_closed + } else { + set tablenames_closed [list] ;#list of lists + } + + foreach sub [lrange $keyval_element 2 end] { + #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey + switch -exact -- [lindex $sub 0] { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - TABLE - ARRAY - ITABLE { + set type [lindex $sub 0] + set value [lindex $sub 1] + set found_sub $sub + incr found_value 1 + } + default {} + } + } + if {!$found_value} { + error "tomlish Failed to find value element in KEY. '$keyval_element'" + } + if {$found_value > 1} { + error "tomlish Found multiple value elements in KEY, expected exactly one. '$keyval_element'" + } + + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + #simple (non-container, no-substitution) datatype + set result [list type $type value $value] + } + STRING - STRINGPART { + set result [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL - LITERALPART { + #REVIEW + set result [list type $type value $value] + } + TABLE { + #invalid? + error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" + } + ITABLE { + #This one should not be returned as a type value structure! + # + set result [::tomlish::to_dict [list $found_sub]] + } + ARRAY { + #we need to recurse to get the corresponding dict for the contained item(s) + #pass in the whole $found_sub - not just the $value! + set prev_tablenames_seen $tablenames_seen + set prev_tablenames_closed $tablenames_closed + set tablenames_seen [list] + set tablenames_closed [list] + set result [list type $type value [::tomlish::to_dict [list $found_sub]]] + set tablenames_seen $prev_tablenames_seen + set tablenames_closed $prev_tablenames_closed + } + MULTISTRING - MULTILITERAL { + #review - mapping these to STRING might make some conversions harder? + #if we keep the MULTI - we know we have to look for newlines for example when converting to json + #without specific types we'd have to check every STRING - and lose info about how best to map chars within it + set result [list type $type value [::tomlish::to_dict [list $found_sub]]] + } + default { + error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" + } + } + return $result + } + + proc _get_dottedkey_info {dottedkeyrecord} { + set key_hierarchy [list] + set key_hierarchy_raw [list] + if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { + error "tomlish _get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" + } + set compoundkeylist [lindex $dottedkeyrecord 1] + set expect_sep 0 + foreach part $compoundkeylist { + set parttag [lindex $part 0] + if {$parttag eq "WS"} { + continue + } + if {$expect_sep} { + if {$parttag ne "DOTSEP"} { + error "DOTTEDKEY missing dot separator between parts. '$dottedkeyrecord'" + } + set expect_sep 0 + } else { + set val [lindex $part 1] + switch -exact -- $parttag { + KEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw $val + } + DQKEY { + lappend key_hierarchy [::tomlish::utils::unescape_string $val] + lappend key_hierarchy_raw \"$val\" + } + SQKEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw "'$val'" + } + default { + error "DOTTED key unexpected part '$parttag' - ensure dot separator is between key parts. '$item'" + } + } + set expect_sep 1 + } + } + return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] + } + + + + #to_dict is a *basic* programmatic datastructure for accessing the data. + # produce a dictionary of keys and values from a tomlish tagged list. + # to_dict is primarily for reading toml data. + #Extraneous (not within quoted sections) whitespace and comments are not preserved in this structure, + # so a roundtrip from toml to this datastructure and back to toml will lose whitespace formatting and comments. + # creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. + #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. + # + + #within an ARRAY, we store a list of items such as plain dicts (possibly empty) and {type value } for simple types + #(ARRAYS can be mixed type) + #This means our dict structure should have only ARRAY and simple types which need to be in {type value } form + #A dict within an array encodeded as a type ITABLE value should also parse - but is the unpreferred form - REVIEW test? + + #Namespacing? + #ie note the difference: + #[Data] + #temp = { cpu = 79.5, case = 72.0} + # versus + #[Data] + #temps = [{cpu = 79.5, case = 72.0}] + proc to_dict {tomlish} { + + #keep track of which tablenames have already been directly defined, + # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' + #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. + #we don't error out just because a previous tablename segment has already appeared. + ##variable tablenames_seen [list] + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] ;#list of lists + } + if {[uplevel 1 [list info exists tablenames_closed]]} { + upvar tablenames_closed tablenames_closed + } else { + set tablenames_closed [list] ;#list of lists + } + + log::info "---> to_dict processing '$tomlish'<<<" + set items $tomlish + + foreach lst $items { + if {[lindex $lst 0] ni $::tomlish::tags} { + error "supplied string does not appear to be toml parsed into a tomlish tagged list. Run tomlish::decode::toml on the raw toml data to produce a tomlish list" + } + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + #ignore TOMLISH tag at beginning + set items [lrange $tomlish 1 end] + } + + set datastructure [dict create] + foreach item $items { + set tag [lindex $item 0] + #puts "...> item:'$item' tag:'$tag'" + switch -exact -- $tag { + KEY - DQKEY - SQKEY { + log::debug "---> to_dict item: processing $tag: $item" + set key [lindex $item 1] + if {$tag eq "DQKEY"} { + set key [::tomlish::utils::unescape_string $key] + } + #!todo - normalize key. (may be quoted/doublequoted) + + if {[dict exists $datastructure $key]} { + error "Duplicate key '$key'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #lassign [_get_keyval_value $item] type val + set keyval_dict [_get_keyval_value $item] + dict set datastructure $key $keyval_dict + } + DOTTEDKEY { + log::debug "---> to_dict item processing $tag: $item" + set dkey_info [_get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + + #a.b.c = 1 + #table_key_hierarchy -> a b + #leafkey -> c + if {[llength $dotted_key_hierarchy] == 0} { + #empty?? probably invalid. review + #This is different to '' = 1 or ''.'' = 1 which have lengths 1 and 2 respectively + error "DOTTED key has no parts - invalid? '$item'" + } elseif {[llength $dotted_key_hierarchy] == 1} { + #dottedkey is only a key - no table component + set table_hierarchy [list] + set leafkey [lindex $dotted_key_hierarchy 0] + } else { + set table_hierarchy [lrange $dotted_key_hierarchy 0 end-1] + set leafkey [lindex $dotted_key_hierarchy end] + } + + #ensure empty tables are still represented in the datastructure + #review - this seems unnecessary? + set pathkeys [list] + foreach k $table_hierarchy { + lappend pathkeys $k + if {![dict exists $datastructure {*}$pathkeys]} { + dict set datastructure {*}$pathkeys [list] + } else { + tomlish::log::notice "to_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" + } + } + #review? + if {[dict exists $datastructure {*}$table_hierarchy $leafkey]} { + error "Duplicate key '$table_hierarchy $leafkey'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #JMN test 2025 + if {[llength $table_hierarchy]} { + lappend tablenames_seen $table_hierarchy + } + + set keyval_dict [_get_keyval_value $item] + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + lappend tablenames_seen [list {*}$table_hierarchy $leafkey] + lappend tablenames_closed [list {*}$table_hierarchy $leafkey] + + #review - item is an ITABLE - we recurse here without datastructure context :/ + #overwriting keys? todo ? + dict set datastructure {*}$table_hierarchy $leafkey $keyval_dict + } else { + dict set datastructure {*}$table_hierarchy $leafkey $keyval_dict + } + + } + TABLE { + set tablename [lindex $item 1] + #set tablename [::tomlish::utils::tablename_trim $tablename] + set norm_segments [::tomlish::utils::tablename_split $tablename true] ;#true to normalize + if {$norm_segments in $tablenames_seen} { + error "Table name '$tablename' has already been directly defined in the toml data. Invalid." + } + + log::debug "---> to_dict processing item $tag (name: $tablename): $item" + set name_segments [::tomlish::utils::tablename_split $tablename] ;#unnormalized + set last_seg "" + #toml spec rule - all segments mst be non-empty + #note that the results of tablename_split are 'raw' - ie some segments may be enclosed in single or double quotes. + + set table_key_sublist [list] + + foreach normseg $norm_segments { + lappend table_key_sublist $normseg + if {[dict exists $datastructure {*}$table_key_sublist]} { + #It's ok for this key to already exist *if* it was defined by a previous tablename or equivalent + #and if this key is longer + + #consider the following 2 which are legal: + #[table] + #x.y = 3 + #[table.x.z] + #k= 22 + + #equivalent + + #[table] + #[table.x] + #y = 3 + #[table.x.z] + #k=22 + + #illegal + #[table] + #x.y = 3 + #[table.x.y.z] + #k = 22 + ## - we should fail on encountering table.x.y because only table and table.x are effectively tables + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + + #note: it is not safe to compare normalized tablenames using join! + # e.g a.'b.c'.d is not the same as a.b.c.d + # instead compare {a b.c d} with {a b c d} + # Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. + #'a.b'.'c.d.e' vs 'a.b.c'.'d.e' + #we need to normalize the tablenames seen so that {"x\ty"} matches {"xy"} + + set sublist_length [llength $table_key_sublist] + set found_testkey 0 + if {$table_key_sublist in $tablenames_seen} { + set found_testkey 1 + } else { + #see if it was defined by a longer entry + foreach seen_table_segments $tablenames_seen { + if {[llength $seen_table_segments] <= $sublist_length} { + continue + } + #each tablenames_seen entry is already a list of normalized segments + + #we could have [a.b.c.d] early on + # followed by [a.b] - which was still defined by the earlier one. + + set seen_longer [lrange $seen_segments 0 [expr {$sublist_length -1}]] + puts stderr "testkey:'$table_key_sublist' vs seen_match:'$seen_longer'" + if {$table_key_sublist eq $seen_longer} { + set found_testkey 1 + } + } + } + + if {$found_testkey == 0} { + #the raw table_key_hierarchy is better to display in the error message, although it's not the actual dict keyset + set msg "key $table_key_sublist already exists in datastructure, but wasn't defined by a supertable." + append msg \n "tablenames_seen:" \n + foreach ts $tablenames_seen { + append msg " " $ts \n + } + error $msg + } + } + + } + + #ensure empty tables are still represented in the datastructure + set table_keys [list] + foreach k $table_key_hierarchy { + lappend table_keys $k + if {![dict exists $datastructure {*}$table_keys]} { + dict set datastructure {*}$table_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (TABLE) subkey $table_keys already had data: [dict get $datastructure {*}$table_keys]" + } + } + + #We must do this after the key-collision test above! + lappend tablenames_seen $norm_segments + + + log::debug ">>> to_dict >>>>>>>>>>>>>>>>> table_key_hierarchy : $table_key_hierarchy" + + #now add the contained elements + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [_get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + set dotted_key_hierarchy [dict get $dkey_info keys] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + set leaf_key [lindex $dotted_key_hierarchy end] + + #ensure empty keys are still represented in the datastructure + set test_keys $table_keys + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { + error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> $keyval_dict" + dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + #JMN 2025 + lappend tablenames_seen [list {*}$table_key_hierarchy {*}$dkeys] + + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + lappend tablenames_seen [list {*}$table_key_hierarchy {*}$dkeys $leaf_key] + #if the keyval_dict is not a simple type x value y - then it's an inline table ? + #if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + } + + } + KEY - DQKEY - SQKEY { + #obsolete ? + set keyval_key [lindex $element 1] + if {$type eq "DQKEY"} { + set keyval_key [::tomlish::utils::unescape_string $keyval_key] + } + if {[dict exists $datastructure {*}$dotted_key_hierarchy $keyval_key]} { + error "Duplicate key '$dotted_key_hierarchy $key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + dict set datastructure {*}$dotted_key_hierarchy $keyval_key $keyval_dict + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in table context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + #now make sure we add an empty value if there were no contained elements! + #!todo. + } + ITABLE { + #SEP??? + set datastructure [list] + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [_get_dottedkey_info $element] + set dotted_key_hierarchy [dict get $dkey_info keys] + set leaf_key [lindex $dotted_key_hierarchy end] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + + #ensure empty keys are still represented in the datastructure + set table_keys [list] ;#We don't know the context - next level up will have to check for key collisions? + set test_keys $table_keys + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { + error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + } + ARRAY { + #arrays in toml are allowed to contain mixtures of types + set datastructure [list] + log::debug "--> processing array: $item" + + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + STRING { + set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + ITABLE { + #anonymous table + #lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + lappend datastructure [::tomlish::to_dict [list $element]] ;#store itables within arrays as raw dicts (possibly empty) + } + TABLE { + #invalid? shouldn't be output from from_dict - but could manually be constructed as such? review + #doesn't make sense as table needs a name? + #take as synonym for ITABLE? + error "to_dict TABLE within array unexpected" + } + ARRAY - MULTISTRING - MULTILITERAL { + #set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + } + WS - SEP - NEWLINE - COMMENT { + #ignore whitespace, commas, newlines and comments + } + default { + error "Unexpected value type '$type' found in array" + } + } + } + } + MULTILITERAL { + #triple squoted string + #first newline stripped only if it is the very first element + #(ie *immediately* following the opening delims) + #All whitespace other than newlines is within LITERALPARTS + # ------------------------------------------------------------------------- + #todo - consider extension to toml to allow indent-aware multiline literals + # how - propose as issue in toml github? Use different delim? e.g ^^^ ? + #e.g + # xxx=?'''abc + # def + # etc + # ''' + # - we would like to trimleft each line to the column following the opening delim + # ------------------------------------------------------------------------- + + log::debug "---> todict processing multiliteral: $item" + set parts [lrange $item 1 end] + if {[lindex $parts 0 0] eq "NEWLINE"} { + set parts [lrange $parts 1 end] ;#skip it + } + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + switch -exact -- $type { + LITERALPART { + append stringvalue [lindex $element 1] + } + NEWLINE { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + MULTISTRING { + #triple dquoted string + log::debug "---> to_dict processing multistring: $item" + set stringvalue "" + set idx 0 + set parts [lrange $item 1 end] + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + #We use STRINGPART in the tomlish representation as a distinct element to STRING - which would imply wrapping quotes to be reinserted + switch -exact -- $type { + STRING { + #todo - do away with STRING ? + #we don't build MULTISTRINGS containing STRING - but should we accept it? + tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" + append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" + } + STRINGPART { + append stringvalue [::tomlish::utils::unescape_string [lindex $element 1]] + } + CONT { + #When the last non-whitespace character on a line is an unescaped backslash, + #it will be trimmed along with all whitespace (including newlines) up to the next non-whitespace character or closing delimiter + # review - we allow some whitespace in stringpart elements - can a stringpart ever be all whitespace? + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + append stringvalue "\\" ;#add the sep + } else { + #skip over ws without emitting + set idx [llength $parts] + } + } else { + set parts_til_nl [lrange $parts 0 $next_nl-1] + set non_ws [lsearch -index 0 -start $idx+1 -not $parts_til_nl WS] + if {$non_ws >= 0} { + append stringvalue "\\" + } else { + #skip over ws on this line + set idx $next_nl + #then have to check each subsequent line until we get to first non-whitespace + set trimming 1 + while {$trimming && $idx < [llength $parts]} { + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + } else { + set idx [llength $parts] + } + set trimming 0 + } else { + set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + set trimming 0 + } else { + set idx $next_nl + #keep trimming + } + } + } + } + } + } + NEWLINE { + #if newline is first element - it is not part of the data of a multistring + if {$idx > 0} { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + } + WS { + append stringvalue [lindex $element 1] + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + WS - COMMENT - NEWLINE { + #ignore + } + default { + error "Unexpected tag '$tag' in Tomlish list '$tomlish'" + } + } + } + return $datastructure + } + + + proc _from_dictval_tomltype {parents tablestack keys typeval} { + set type [dict get $typeval type] + set val [dict get $typeval value] + switch -- $type { + ARRAY { + set subitems [list] + foreach item $val { + lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP + } + if {[lindex $subitems end] eq "SEP"} { + set subitems [lrange $subitems 0 end-1] + } + return [list ARRAY {*}$subitems] + } + ITABLE { + if {$val eq ""} { + return ITABLE + } else { + return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] + } + } + MULTISTRING { + #value is a raw string that isn't encoded as tomlish + #create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format + #We need to convert controls in $val to escape sequences - except for newlines + # + #consider an *option* to reformat for long lines? (perhaps overcomplex - byte equiv - but may fold in ugly places) + #we could use a line-length limit to decide when to put in a "line ending backslash" + #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW + # + #TODO + set tomlpart "x=\"\"\"\\\n" + append tomlpart $val "\"\"\"" + set tomlish [tomlish::decode::toml $tomlpart] + #e.g if val = " etc\nblah" + #TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } + #lindex 1 3 is the MULTISTRING tomlish list + return [lindex $tomlish 1 3] + } + MULTILITERAL { + #MLL string can contain newlines - but still no control chars + #todo - validate + set tomlpart "x='''\n" + append tomlpart $val ''' + set tomlish [tomlish::decode::toml $tomlpart] + return [lindex $tomlish 1 3] + } + LITERAL { + #from v1.0 spec - "Control characters other than tab are not permitted in a literal string" + #(This rules out raw ANSI SGR - which is somewhat restrictive - but perhaps justified for a config format + # as copy-pasting ansi to a config value is probably not always wise, and it's not something that can be + # easily input via a text editor. ANSI can go in Basic strings using the \e escape if that's accepted v1.1?) + #we could choose to change the type to another format here when encountering invalid chars - but that seems + #like too much magic. We elect to error out and require the dict to have valid data for the types it specifies. + if {[string first ' $val] >=0} { + error "_from_dictval_tomltype error: single quote found in LITERAL - cannot encode dict to TOML-VALID TOMLISH" + } + #detect control chars other than tab + #for this we can use rawstring_to_Bstring_with_escaped_controls - even though this isn't a Bstring + #we are just using the map to detect a difference. + set testval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val] + if {$testval ne $val} { + #some escaping would have to be done if this value was destined for a Bstring... + #therefor this string has controls and isn't suitable for a LITERAL according to the specs. + error "_from_dictval_tomltype error: control chars (other than tab) found in LITERAL value - cannot encode dict to TOML-VALID TOMLISH" + } + return [list LITERAL $val] + } + STRING { + return [list STRING [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val]] + } + INT { + if {![::tomlish::utils::is_int $val]} { + error "_from_dictval_tomltype error: bad INT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list INT $val] + } + FLOAT { + if {![::tomlish::utils::is_float $val]} { + error "_from_dictval_tomltype error: bad FLOAT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list FLOAT $val] + } + default { + if {$type ni [::tomlish::tags]} { + error "_from_dictval_tomltype error: Unrecognised typename '$type' in {type value } - cannot encode dict to TOML-VALID TOMLISH" + } + return [list $type $val] + } + } + } + + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + if {[regexp {\s} $k] || [string first . $k] >= 0} {} + if {![::tomlish::utils::is_barekey $k]} { + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + #requires quoting + #we'll use a basic mechanism for now to determine the type of quoting - whether it has any single quotes or not. + #todo - more? + #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) + if {[string first ' $k] >=0} { + #basic string + } else { + #literal string + set K_PART [list SQKEY $k] + } + } else { + set K_PART [list KEY $k] + } + puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" + puts stderr "---tablestack: $tablestack---" + set result [list] + set lastparent [lindex $parents end] + if {$lastparent in [list "" do_inline]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + set type [dict get $vinfo type] + #treat ITABLE differently? + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} + } else { + #set result [list TABLE $k {NEWLINE lf}] + if {$vinfo ne ""} { + + #set result [list DOTTEDKEY [list [list KEY $k]] = ] + #set records [list ITABLE] + + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + + if {$lastparent eq "do_inline"} { + set result [list DOTTEDKEY [list $K_PART] =] + set records [list ITABLE] + } else { + #review - quoted k ?? + set result [list TABLE $k {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $k]] + set records [list] + } + + + + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + dict for {vk vv} $vinfo { + if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + set VK_PART [list SQKEY $vk] + } else { + set VK_PART [list KEY $vk] + } + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] + } else { + if {$vv eq ""} { + #experimental + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" + #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] + set tname [join [list {*}$keys $vk] .] + set record [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + } else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + } + } else { + if { 0 } { + #experiment.. sort of getting there. + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" + set tname [join [list {*}$keys $vk] .] + set record [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + + #review - todo? + set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] + lappend record {*}$dottedkey_value + + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + } + if {$dictidx != $lastidx} { + #lappend record SEP + if {$lastparent eq "do_inline"} { + lappend record SEP + } else { + lappend record {NEWLINE lf} + } + } + lappend records $record + incr dictidx + } + if {$lastparent eq "do_inline"} { + lappend result $records {NEWLINE lf} + } else { + lappend result {*}$records {NEWLINE lf} + } + } else { + if {$lastparent eq "do_inline"} { + lappend result DOTTEDKEY [list [list KEY $k]] = ITABLE {NEWLINE lf} + } else { + lappend result TABLE $k {NEWLINE lf} + } + } + } + } else { + #lastparent is not toplevel "" or "do_inline" + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result {*}$sublist + } else { + if {$lastparent eq "TABLE"} { + #review + dict for {vk vv} $vinfo { + set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] + lappend result [list DOTTEDKEY [list [list KEY $vk]] = $dottedkey_value {NEWLINE lf}] + } + } else { + if {$vinfo ne ""} { + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + set sub [list] + #REVIEW + #set result $lastparent ;#e.g sets ITABLE + set result ITABLE + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + dict for {vk vv} $vinfo { + if {[regexp {\s} $vk] || [string first . $vk] >=0} { + set VK_PART [list SQKEY $vk] + } else { + set VK_PART [list KEY $vk] + } + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART] = $sublist] + } else { + if {$vv eq ""} { + #can't just uninline at this level + #we need a better method to query main dict for uninlinability at each level + # (including what's been inlined already) + #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + # puts stderr "_from_dictval uninline2 KEY $keys" + # set tname [join [list {*}$keys $vk] .] + # set record [list TABLE $tname {NEWLINE lf}] + # set tablestack [list {*}$tablestack [list T $vk]] + #} else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + #} + } else { + #set sub [_from_dictval ITABLE $vk $vv] + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + #set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + if {$dictidx != $lastidx} { + lappend record SEP + } + lappend result $record + incr dictidx + } + } else { + puts stderr "table x-1" + lappend result DOTTEDKEY [list $K_PART] = ITABLE + } + } + } + } + return $result + } + + + proc from_dict {d} { + #consider: + # t1={a=1,b=2} + # x = 1 + #If we represent t1 as an expanded table we get + # [t1] + # a=1 + # b=2 + # x=1 + # --- which is incorrect - as x was a toplevel key like t1! + #This issue doesn't occur if x is itself an inline table + # t1={a=1,b=2} + # x= {no="problem"} + # + # (or if we were to reorder x to come before t1) + + #As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} + #Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, + #which is unpreferred here. + + #A possible solution: + #scan the top level to see if all (trailing) elements are themselves dicts + # (ie not of form {type XXX value yyy}) + # + # A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements + #ie we don't need to force do_inline if all the 'simple' keys are before any compound keys + + #set root_has_values 0 + #approach 1) - the naive approach - forces inline when not always necessary + #dict for {k v} $d { + # if {[llength $v] == 4 && [lindex $v 0] eq "type"} { + # set root_has_values 1 + # break + # } + #} + + + #approach 2) - track the position of last {type x value y} in the dictionary built by to_dict + # - still not perfect. Inlines dotted tables unnecessarily + #This means from_dict doesn't produce output optimal for human editing. + set last_simple [tomlish::dict::last_tomltype_posn $d] + + + ## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values + #Any keys that are themselves tables - will need to be represented inline + #to avoid reordering, or incorrect assignment of plain values to the wrong table. + + ## set parent "" + #all toplevel keys in the dict structure can represent subtables. + #we are free to use {[tablename]\n} syntax for toplevel elements. + + + set tomlish [list TOMLISH] + set dictposn 0 + set tablestack [list [list T root]] ;#todo + dict for {t tinfo} $d { + if {$last_simple > $dictposn} { + set parents [list do_inline] + } else { + set parents [list ""] + } + set keys [list $t] + set trecord [_from_dictval $parents $tablestack $keys $tinfo] + lappend tomlish $trecord + incr dictposn + } + return $tomlish + } + + proc json_to_toml {json} { + #*** !doctools + #[call [fun json_to_toml] [arg json]] + #[para] + + set tomlish [::tomlish::from_json $json] + set toml [::tomlish::to_toml $tomlish] + } + + #TODO use huddle? + proc from_json {json} { + #set jstruct [::tomlish::json_struct $json] + #return [::tomlish::from_json_struct $jstruct] + package require huddle + package require huddle::json + set h [huddle::json::json2huddle parse $json] + + } + + proc from_json_struct {jstruct} { + package require fish::json_toml + return [fish::json_toml::jsonstruct2tomlish $jstruct] + } + + proc toml_to_json {toml} { + set tomlish [::tomlish::from_toml $toml] + return [::tomlish::get_json $tomlish] + } + + proc get_json {tomlish} { + package require fish::json + set d [::tomlish::to_dict $tomlish] + #return [::tomlish::dict_to_json $d] + return [fish::json::from "struct" $d] + } + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +namespace eval tomlish::build { + #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness + # take a value of the appropriate type and wrap as a tomlish tagged item + proc STRING {s} { + return [list STRING [::tomlish::utils::rawstring_to_Bstring_with_escaped_controls $s]] + } + proc LITERAL {litstring} { + + } + + proc INT {i} { + #whole numbers, may be prefixed with a + or - + #Leading zeros are not allowed + #Hex,octal binary forms are allowed (toml 1.0) + #We will error out on encountering commas, as commas are interpreted differently depending on locale (and don't seem to be supported in the toml spec anyway) + #!todo - Tcl can handle bignums - bigger than a 64bit signed long as specified in toml. + # - We should probably raise an error for number larger than this and suggest the user supply it as a string? + if {[tcl::string::last , $i] > -1} { + error "Unable to interpret '$i' as an integer. Use underscores if you need a thousands separator [::tomlish::parse::report_line]" + } + if {![::tomlish::utils::int_validchars $i]} { + error "Unable to interpret '$i' as an integer. Only 0-9 + 1 _ characters are acceptable. [::tomlish::parse::report_line]" + } + + if {[::tomlish::utils::is_int $i]} { + return [list INT $i] + } else { + error "'$i' is not a valid integer as per the Toml spec. [::tomlish::parse::report_line]" + } + + } + + proc FLOAT {f} { + #convert any non-lower case variants of special values to lowercase for Toml + if {[::tcl::string::tolower $f] in {nan +nan -nan inf +inf -inf}} { + return [list FLOAT [tcl::string::tolower $f]] + } + if {[::tomlish::utils::is_float $f]} { + return [list FLOAT $f] + } else { + error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" + } + } + + proc DATETIME {str} { + if {[::tomlish::utils::is_datetime $str]} { + return [list DATETIME $str] + } else { + error "Unable to interpret '$str' as Toml datetime. Check your input, or check that tomlish is able to handle all Toml datetimes properly [::tomlish::parse::report_line]" + } + } + + proc BOOLEAN {b} { + #convert any Tcl-acceptable boolean to boolean as accepted by toml - lower case true/false + if {![tcl::string::is boolean -strict $b]} { + error "Unable to convert '$b' to Toml boolean true|false. [::tomlish::parse::report_line]" + } else { + if {$b && 1} { + return [::list BOOL true] + } else { + return [::list BOOL false] + } + } + } + + #REVIEW + #Take tablename followed by + # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} + # (accept also key value {STRING }) + # b) simple 2-element tcl lists being name & *simple* value pairs for which basic heuristics will be used to determine types + proc _table {name args} { + set pairs [list] + foreach t $args { + if {[llength $t] == 4} { + if {[tcl::string::tolower [lindex $t 0]] ne "key" || [tcl::string::tolower [lindex $t 2]] ni "= value"} { + error "Only items tagged as KEY = currently accepted as name-value pairs for table command" + } + lassign $t _k keystr _eq valuepart + if {[llength $valuepart] != 2} { + error "supplied value must be typed. e.g {INT 1} or {STRING test}" + } + lappend pairs [list KEY $keystr = $valuepart] + } elseif {[llength $t] == 2} { + #!todo - type heuristics + lassign $t n v + lappend pairs [list KEY $n = [list STRING $v]] + } else { + error "'KEY = { toml but + # the first newline is not part of the data. + # we elect instead to maintain a basic LITERALPART that must not contain newlines.. + # and to compose MULTILITERAL of multiple NEWLINE LITERALPART parts, + #with the datastructure representation dropping the first newline (if immediately following opening delim) when building the value. + set literal "" + foreach part [lrange $item 1 end] { + append literal [::tomlish::encode::tomlish [list $part] $nextcontext] + } + append toml '''$literal''' + } + INT - + BOOL - + FLOAT - + DATETIME { + append toml [lindex $item 1] + } + INCOMPLETE { + error "cannot process tomlish term tagged as INCOMPLETE" + } + COMMENT { + append toml "#[lindex $item 1]" + } + BOM { + #Byte Order Mark may appear at beginning of a file. Needs to be preserved. + append toml "\uFEFF" + } + default { + error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command." + } + } + + } + return $toml + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::encode ---}] +} +#fish toml from tomlish + +#(encode tomlish as toml) +interp alias {} tomlish::to_toml {} tomlish::encode::tomlish + +# + + +namespace eval tomlish::decode { + #*** !doctools + #[subsection {Namespace tomlish::decode}] + #[para] + #[list_begin definitions] + + #return a Tcl list of tomlish tokens + #i.e get a standard list of all the toml terms in string $s + #where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. + #(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) + # ---------------------------------------------------------------------------------------------- + # NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! + # e.g we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- + #Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. + # (e.g perhaps a toml editor to highlight violations for fixing) + # A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. + # e.g dicts or an object oriented structure + #Note also - *no* escapes in quoted strings are processed. This is up to the datastructure stage + #e.g to_dict will substitute \r \n \uHHHH \UHHHHHHH etc + #This is important for tomlish to maintain the ability to perform competely lossless round-trips from toml to tomlish and back to toml. + # (which is handy for testing as well as editing some part of the structure with absolutely no effect on other parts of the document) + #If we were to unescape a tab character for example + # - we have no way of knowing if it was originally specified as \t \u0009 or \U00000009 or directly as a tab character. + # For this reason, we also do absolutely no line-ending transformations based on platform. + # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + + proc toml {args} { + #*** !doctools + #[call [fun toml] [arg arg...]] + #[para] return a Tcl list of tomlish tokens + + set s [join $args \n] + + namespace upvar ::tomlish::parse is_parsing is_parsing + set is_parsing 1 + + if {[info command ::tomlish::parse::spacestack] eq "::tomlish::parse::spacestack"} { + tomlish::parse::spacestack destroy + } + struct::stack ::tomlish::parse::spacestack + + namespace upvar ::tomlish::parse last_space_action last_space_action + namespace upvar ::tomlish::parse last_space_type last_space_type + + namespace upvar ::tomlish::parse tok tok + set tok "" + + namespace upvar ::tomlish::parse type type + namespace upvar ::tomlish::parse tokenType tokenType + ::tomlish::parse::set_tokenType "" + namespace upvar ::tomlish::parse tokenType_list tokenType_list + set tokenType [list] ;#Flat (un-nested) list of tokentypes found + + namespace upvar ::tomlish::parse lastChar lastChar + set lastChar "" + + + set result "" + namespace upvar ::tomlish::parse nest nest + set nest 0 + + namespace upvar ::tomlish::parse v v ;#array keyed on nest level + + + set v(0) {TOMLISH} + array set s0 [list] ;#whitespace data to go in {SPACE {}} element. + set parentlevel 0 + + namespace upvar ::tomlish::parse i i + set i 0 + + namespace upvar ::tomlish::parse state state + + namespace upvar ::tomlish::parse braceCount braceCount + set barceCount 0 + namespace upvar ::tomlish::parse bracketCount bracketCount + set bracketCount 0 + + set sep 0 + set r 1 + namespace upvar ::tomlish::parse token_waiting token_waiting + set token_waiting [dict create] ;#if ::tok finds a *complete* second token during a run, it will put the 2nd one here to be returned by the next call. + + + set state "table-space" + ::tomlish::parse::spacestack push {type space state table-space} + namespace upvar ::tomlish::parse linenum linenum;#'line number' of input data. (incremented for each literal linefeed - but not escaped ones in data) + set linenum 1 + + set ::tomlish::parse::state_list [list] + try { + while {$r} { + set r [::tomlish::parse::tok $s] + #puts stdout "got tok: '$tok' while parsing string '$s' " + set next_tokenType_known 0 ;#whether we begin a new token here based on what terminated the token result of 'tok' + + + #puts "got token: '$tok' tokenType='$tokenType'. while v($nest) = [set v($nest)]" + #puts "-->tok: $tok tokenType='$tokenType'" + set prevstate $state + set transition_info [::tomlish::parse::goNextState $tokenType $tok $state] + #review goNextState could perform more than one space_action + set space_action [dict get $transition_info space_action] + set newstate [dict get $transition_info newstate] ;#use of 'newstate' vs 'state' makes code clearer below + + if {[tcl::string::match "err-*" $state]} { + ::tomlish::log::warn "---- State error in state $prevstate for tokenType: $tokenType token value: $tok. $state aborting parse. [tomlish::parse::report_line]" + lappend v(0) [list ERROR tokentype $tokenType state $prevstate to $state leveldata [set v($nest)]] + return $v(0) + } + # --------------------------------------------------------- + #NOTE there may already be a token_waiting at this point + #set_token_waiting can raise an error here, + # in which case the space_action branch needs to be rewritten to handle the existing token_waiting + # --------------------------------------------------------- + + if {$space_action eq "pop"} { + #pop_trigger_tokens: newline tablename endarray endinlinetable + #note a token is a pop trigger depending on context. e.g first newline during keyval is a pop trigger. + set parentlevel [expr {$nest -1}] + set do_append_to_parent 1 ;#most tokens will leave this alone - but some like squote_seq need to do their own append + switch -exact -- $tokenType { + squote_seq { + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the xxx-squote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + switch -- $tok { + ' { + tomlish::parse::set_token_waiting type startsquote value $tok complete 1 startindex [expr {$i -1}] + } + '' { + #review - we should perhaps return double_squote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_squote value "" complete 1 startindex [expr {$i - 2}] + } + ''' { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 3}] + } + '''' { + switch -exact -- $prevstate { + leading-squote-space { + error "---- 4 squotes from leading-squote-space - shouldn't get here" + #we should have emitted the triple and left the last for next loop + } + trailing-squote-space { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left squote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]'" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "'"] + } + default { + error "--- don't know how to integrate extra trailing squote with data $v($parentlevel)" + } + } + } + default { + error "--- unexpected popped due to squote_seq but came from state '$prevstate' should have been leading-squote-space or trailing-squote-space" + } + } + } + ''''' { + switch -exact -- $prevstate { + leading-squote-space { + error "---- 5 squotes from leading-squote-space - shouldn't get here" + #we should have emitted the triple and left the following squotes for next loop + } + trailing-squote-space { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 squotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]''" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [LITERALPART "''"] + } + default { + error "--- don't know how to integrate extra trailing 2 squotes with data $v($parentlevel)" + } + } + } + default { + error "--- unexpected popped due to squote_seq but came from state '$prevstate' should have been leading-squote-space or trailing-squote-space" + } + } + } + } + puts stderr "tomlish::decode::toml ---- HERE squote_seq pop <$tok>" + } + triple_squote { + #presumably popping multiliteral-space + ::tomlish::log::debug "---- triple_squote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTILITERAL { + lappend merged $part + } + LITERALPART { + if {$lasttype eq "LITERALPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_squote unhandled part type [lindex $part 0] unable to merge leveldata: $v($next)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + equal { + #pop caused by = + switch -exact -- $prevstate { + dottedkey-space { + tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + dottedkey-space-tail { + #experiment? + tomlish::log::debug "---- equal ending dottedkey-space-tail for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + } + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + tablename { + #note: a tablename only 'pops' if we are greater than zero + error "---- tablename pop should already have been handled as special case zeropoppushspace in goNextState" + } + tablearrayname { + #!review - tablearrayname different to tablename regarding push/pop? + #note: a tablename only 'pops' if we are greater than zero + error "---- tablearrayname pop should already have been handled as special case zeropoppushspace in goNextState" + } + endarray { + #nothing to do here. + } + comma { + #comma for inline table will pop the keyvalue space + lappend v($nest) "SEP" + } + endinlinetable { + ::tomlish::log::debug "---- endinlinetable for last_space_action pop" + } + endmultiquote { + ::tomlish::log::debug "---- endmultiquote for last_space_action 'pop'" + } + default { + error "---- unexpected tokenType '$tokenType' for last_space_action 'pop'" + } + } + if {$do_append_to_parent} { + #e.g squote_seq does it's own appends as necessary - so won't get here + lappend v($parentlevel) [set v($nest)] + } + + incr nest -1 + + } elseif {$last_space_action eq "push"} { + set prevnest $nest + incr nest 1 + set v($nest) [list] + # push_trigger_tokens: barekey dquotedkey startinlinetable startarray tablename tablearrayname + + + switch -exact -- $tokenType { + squote_seq_begin { + #### + if {[dict exists $transition_info starttok] && [dict get $transition_info starttok] ne ""} { + lassign [dict get $transition_info starttok] starttok_type starttok_val + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType $starttok_type + set tok $starttok_val + } + } + squotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + dquotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + XXXdquotedkey - XXXitablequotedkey { + #todo + set v($nest) [list DQKEY $tok] ;#$tok is the keyname + } + barekey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + set waiting [tomlish::parse::get_token_waiting] + if {[llength $waiting]} { + set i [dict get $waiting startindex] + tomlish::parse::clear_token_waiting + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } else { + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + } + startsquote { + #JMN + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + tablename { + #note: we do not use the output of tomlish::tablename_trim to produce a tablename for storage in the tomlish list! + #The tomlish list is intended to preserve all whitespace (and comments) - so a roundtrip from toml file to tomlish + # back to toml file will be identical. + #It is up to the datastructure stage to normalize and interpret tomlish for programmatic access. + # we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, + # so we can raise an error at this point rather than create a tomlish list with obviously invalid table names. + + #todo - review! It's arguable that we should not do any validation here, and just store even incorrect raw tablenames, + # so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the + # tomlish list? + + set test_only [::tomlish::utils::tablename_trim $tok] + ::tomlish::log::debug "---- trimmed (but not normalized) tablename: '$test_only'" + set v($nest) [list TABLE $tok] ;#$tok is the *raw* table name + #note also that equivalent tablenames may have different toml representations even after being trimmed! + #e.g ["x\t\t"] & ["x "] (tab escapes vs literals) + #These will show as above in the tomlish list, but should normalize to the same tablename when used as keys by the datastructure stage. + } + tablearrayname { + set test_only [::tomlish::utils::tablename_trim $tok] + puts stdout "trimmed (but not normalized) tablearrayname: '$test_only'" + set v($nest) [list TABLEARRAY $tok] ;#$tok is the *raw* tablearray name + } + startarray { + set v($nest) [list ARRAY] ;#$tok is just the opening bracket - don't output. + } + startinlinetable { + set v($nest) [list ITABLE] ;#$tok is just the opening curly brace - don't output. + } + startmultiquote { + ::tomlish::log::debug "---- push trigger tokenType startmultiquote" + set v($nest) [list MULTISTRING] ;#container for STRINGPART, WS, CONT, NEWLINE + } + triple_squote { + ::tomlish::log::debug "---- push trigger tokenType triple_squote" + set v($nest) [list MULTILITERAL] ;#container for NEWLINE,LITERAL + } + default { + error "---- push trigger tokenType '$tokenType' not yet implemented" + } + } + + } else { + #no space level change + switch -exact -- $tokenType { + squotedkey { + puts "---- squotedkey in state $prevstate (no space level change)" + lappend v($nest) [list SQKEY $tok] + } + dquotedkey { + puts "---- dquotedkey in state $prevstate (no space level change)" + lappend v($nest) [list DQKEY $tok] + } + barekey { + lappend v($nest) [list KEY $tok] + } + dotsep { + lappend v($nest) [list DOTSEP] + } + starttablename { + #$tok is triggered by the opening bracket and sends nothing to output + } + starttablearrayname { + #$tok is triggered by the double opening brackets and sends nothing to output + } + tablename - tablenamearray { + error "---- did not expect 'tablename/tablearrayname' without space level change (no space level change)" + #set v($nest) [list TABLE $tok] + } + endtablename - endtablearrayname { + #no output into the tomlish list for this token + } + startinlinetable { + puts stderr "---- decode::toml error. did not expect startinlinetable without space level change (no space level change)" + } + startquote { + switch -exact -- $newstate { + string-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "string" + set tok "" + } + quoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "dquotedkey" + set tok "" + } + XXXitable-quoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "itablequotedkey" + set tok "" + } + default { + error "---- startquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + startsquote { + switch -exact -- $newstate { + literal-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "literal" + set tok "" + } + squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + XXXitable-squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "itablesquotedkey" + set tok "" + } + multiliteral-space { + #false alarm squote returned from squote_seq pop + ::tomlish::log::debug "---- adding lone squote to own LITERALPART nextstate: $newstate (no space level change)" + #(single squote - not terminating space) + lappend v($nest) [list LITERALPART '] + #may need to be joined on pop if there are neighbouring LITERALPARTs + } + default { + error "---- startsquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + startmultiquote { + #review + puts stderr "---- got startmultiquote in state $prevstate (no space level change)" + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "stringpart" + set tok "" + } + endquote { + #nothing to do? + set tok "" + } + endsquote { + set tok "" + } + endmultiquote { + #JMN!! + set tok "" + } + string { + lappend v($nest) [list STRING $tok] ;#directly wrapped in dquotes + } + literal { + lappend v($nest) [list LITERAL $tok] ;#directly wrapped in squotes + } + double_squote { + switch -exact -- $prevstate { + keyval-value-expected { + lappend v($nest) [list LITERAL ""] + } + multiliteral-space { + #multiliteral-space to multiliteral-space + lappend v($nest) [list LITERALPART ''] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + multistring { + #review + lappend v($nest) [list MULTISTRING $tok] + } + stringpart { + lappend v($nest) [list STRINGPART $tok] ;#will not get wrapped in dquotes directly + } + multiliteral { + lappend v($nest) [LIST MULTILITERAL $tok] + } + literalpart { + lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly + } + itablequotedkey { + + } + untyped_value { + #we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. + if {$tok in {true false}} { + set tag BOOL + } elseif {[::tomlish::utils::is_int $tok]} { + set tag INT + } elseif {[::tomlish::utils::is_float $tok]} { + set tag FLOAT + } elseif {[::tomlish::utils::is_datetime $tok]} { + set tag DATETIME + } else { + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + } + lappend v($nest) [list $tag $tok] + + } + comment { + #puts stdout "----- comment token returned '$tok'------" + lappend v($nest) [list COMMENT "$tok"] + } + equal { + #we append '=' to the nest so that any surrounding whitespace is retained. + lappend v($nest) = + } + comma { + lappend v($nest) SEP + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + whitespace { + lappend v($nest) [list WS $tok] + } + continuation { + lappend v($nest) CONT + } + bom { + lappend v($nest) BOM + } + eof { + #ok - nothing more to add to the tomlish list. + #!todo - check previous tokens are complete/valid? + } + default { + error "--- unknown tokenType '$tokenType' during state $prevstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + + if {!$next_tokenType_known} { + ::tomlish::log::notice "---- tomlish::decode::toml - current tokenType:$tokenType Next token type not known" + ::tomlish::parse::set_tokenType "" + set tok "" + } + + if {$state eq "end-state"} { + break + } + + + } + + #while {$nest > 0} { + # lappend v([expr {$nest -1}]) [set v($nest)] + # incr nest -1 + #} + while {[::tomlish::parse::spacestack size] > 1} { + ::tomlish::parse::spacestack pop + lappend v([expr {$nest -1}]) [set v($nest)] + incr nest -1 + + #set parent [spacestack peek] ;#the level being appended to + #lassign $parent type state + #if {$type eq "space"} { + # + #} elseif {$type eq "buffer"} { + # lappend v([expr {$nest -1}]) {*}[set v($nest)] + #} else { + # error "invalid spacestack item: $parent" + #} + } + + } finally { + set is_parsing 0 + } + return $v(0) + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::decode ---}] +} +#decode toml to tomlish +interp alias {} tomlish::from_toml {} tomlish::decode::toml + +namespace eval tomlish::utils { + #*** !doctools + #[subsection {Namespace tomlish::utils}] + #[para] + #[list_begin definitions] + + + #tablenames (& tablearraynames) may contain irrelevant leading, trailing and interspersed whitespace + # tablenames can be made up of segments delimited by dots. .eg [ a.b . c ] + #trimmed, the tablename becomes {a.b.c} + # A segment may contain whitespace if it is quoted e.g [a . b . "c etc " ] + #ie whitespace is only irrelevant if it's outside a quoted segment + #trimmed, the tablename becomes {a.b."c etc "} + proc tablename_trim {tablename} { + set segments [tablename_split $tablename false] + set trimmed_segments [list] + foreach seg $segments { + lappend trimmed_segments [::string trim $seg " \t"] + } + return [join $trimmed_segments .] + } + + #basic generic quote matching for single and double quotes + #note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes + proc tok_in_quotedpart {tok} { + set sLen [tcl::string::length $tok] + set quote_type "" + set had_slash 0 + for {set i 0} {$i < $sLen} {incr i} { + set c [tcl::string::index $tok $i] + if {$quote_type eq ""} { + if {$had_slash} { + #don't enter quote mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + set quote_type dq + } + sq { + set quote_type sq + } + bsl { + set had_slash 1 + } + } + } + } else { + if {$had_slash} { + #don't leave quoted mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + if {$quote_type eq "dq"} { + set quote_type "" + } + } + sq { + if {$quote_type eq "sq"} { + set quote_type "" + } + } + bsl { + set had_slash 1 + } + } + } + } + } + return $quote_type ;#dq | sq + } + + #utils::tablename_split + proc tablename_split {tablename {normalize false}} { + #we can't just split on . because we have to handle quoted segments which may contain a dot. + #eg {dog."tater.man"} + set sLen [tcl::string::length $tablename] + set segments [list] + set mode "unknown" ;#5 modes: unknown, quoted,litquoted, unquoted, syntax + #quoted is for double-quotes, litquoted is for single-quotes (string literal) + set seg "" + for {set i 0} {$i < $sLen} {incr i} { + + if {$i > 0} { + set lastChar [tcl::string::index $tablename [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $tablename $i] + + if {$c eq "."} { + switch -exact -- $mode { + unquoted { + #dot marks end of segment. + lappend segments $seg + set seg "" + set mode "unknown" + } + quoted { + append seg $c + } + unknown { + lappend segments $seg + set seg "" + } + litquoted { + append seg $c + } + default { + #mode: syntax + #we got our dot. - the syntax mode is now satisfied. + set mode "unknown" + } + } + } elseif {($c eq "\"") && ($lastChar ne "\\")} { + if {$mode eq "unknown"} { + if {[tcl::string::trim $seg] ne ""} { + #we don't allow a quote in the middle of a bare key + error "tablename_split. character '\"' invalid at this point in tablename. tablename: '$tablename'" + } + set mode "quoted" + set seg "\"" + } elseif {$mode eq "unquoted"} { + append seg $c + } elseif {$mode eq "quoted"} { + append seg $c + + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + } else { + lappend segments $seg + } + + set seg "" + set mode "syntax" ;#make sure we only accept a dot or end-of-data now. + } elseif {$mode eq "litquoted"} { + append seg $c + } elseif {$mode eq "syntax"} { + error "tablename_split. expected whitespace or dot, got double quote. tablename: '$tablename'" + } + } elseif {($c eq "\'")} { + if {$mode eq "unknown"} { + append seg $c + set mode "litquoted" + } elseif {$mode eq "unquoted"} { + #single quote inside e.g o'neill + append seg $c + } elseif {$mode eq "quoted"} { + append seg $c + + } elseif {$mode eq "litquoted"} { + append seg $c + #no normalization to do + lappend segments $seg + set seg "" + set mode "syntax" + } elseif {$mode eq "syntax"} { + error "tablename_split. expected whitespace or dot, got single quote. tablename: '$tablename'" + } + + } elseif {$c in [list " " \t]} { + if {$mode eq "syntax"} { + #ignore + } else { + append seg $c + } + } else { + if {$mode eq "syntax"} { + error "tablename_split. Expected a dot separator. got '$c'. tablename: '$tablename'" + } + if {$mode eq "unknown"} { + set mode "unquoted" + } + append seg $c + } + if {$i == $sLen-1} { + #end of data + ::tomlish::log::debug "End of data: mode='$mode'" + #REVIEW - we can only end up in unquoted or syntax here? are other branches reachable? + switch -exact -- $mode { + quoted { + if {$c ne "\""} { + error "tablename_split. missing closing double-quote in a segment. tablename: '$tablename'" + } + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + #lappend segments [subst -nocommands -novariables [::string range $seg 1 end-1]] ;#wrong + } else { + lappend segments $seg + } + } + litquoted { + set trimmed_seg [tcl::string::trim $seg] + if {[tcl::string::index $trimmed_seg end] ne "\'"} { + error "tablename_split. missing closing single-quote in a segment. tablename: '$tablename'" + } + lappend segments $seg + } + unquoted - unknown { + lappend segments $seg + } + syntax { + #ok - segment already lappended + } + default { + lappend segments $seg + } + } + } + } + foreach seg $segments { + set trimmed [tcl::string::trim $seg " \t"] + #note - we explicitly allow 'empty' quoted strings '' & "" + # (these are 'discouraged' but valid toml keys) + #if {$trimmed in [list "''" "\"\""]} { + # puts stderr "tablename_split. warning - Empty quoted string as tablename segment" + #} + if {$trimmed eq "" } { + error "tablename_split. Empty segment found. tablename: '$tablename' segments [llength $segments] ($segments)" + } + } + return $segments + } + + proc unicode_escape_info {slashu} { + #!todo + # validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and + # is a valid 'unicode scalar value' (any Unicode code point except high-surrogate and low-surrogate code points) + # ie integers in the range 0 to D7FF16 and E00016 to 10FFFF16 inclusive + #expr {(($x >= 0) && ($x <= 0xD7FF16)) || (($x >= 0xE00016) && ($x <= 0x10FFFF16))} + if {[tcl::string::match {\\u*} $slashu]} { + set exp {^\\u([0-9a-fA-F]{4}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %4x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } + } else { + return [list err [list reason "Supplied string not of the form \\uHHHH where H in \[0-9a-fA-F\]"]] + } + } elseif {[tcl::string::match {\\U*} $slashu]} { + set exp {^\\U([0-9a-fA-F]{8}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %8x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + if {(($dec >= 0) && ($dec <= 0xD7FF16)) || (($dec >= 0xE00016) && ($dec <= 0x10FFFF16))} { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } else { + return [list err [list reason "$slashu is not within the 'unicode scalar value' ranges 0 to 0xD7FF16 or 0xE00016 to 0x10FFFF16"]] + } + } + } else { + return [list err [list reason "Supplied string not of the form \\UHHHHHHHH where H in \[0-9a-fA-F\]"]] + } + } else { + return [list err [list reason "Supplied string did not start with \\u or \\U" ]] + } + + } + + #Note that unicode characters don't *have* to be escaped. + #So if we provide a function named 'escape_string', the name implies the inverse of unescape_string which unescapes unicode \u \U values. + #- an inverse of unescape_string would encode all unicode chars unnecessarily. + #- as toml accepts a compact escape sequence for common chars such as tab,backspace,linefeed etc but also allows the full form \u009 etc + #- escape_string and unescape_string would not be reliably roundtrippable inverses anyway. + #REVIEW - provide it anyway? When would it be desirable to use? + + variable Bstring_control_map [list\ + \b {\b}\ + \n {\n}\ + \r {\r}\ + \" {\"}\ + \x1b {\e}\ + \\ "\\\\"\ + ] + #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ + #for a Bstring (Basic string) tab is explicitly mentioned as not being one that must be escaped. + for {set cdec 0} {$cdec <= 8} {incr cdec} { + set hhhh [format %.4X $cdec] + lappend Bstring_control_map [format %c $cdec] \\u$hhhh + } + for {set cdec [expr {0x0A}]} {$cdec <= 0x1F} {incr cdec} { + set hhhh [format %.4X $cdec] + lappend Bstring_control_map [format %c $cdec] \\u$hhhh + } + # \u007F = 127 + lappend Bstring_control_map [format %c 127] \\u007F + + #Note the inclusion of backslash in the list of controls makes this non idempotent - subsequent runs would keep encoding the backslashes! + #escape only those chars that must be escaped in a Bstring (e.g not tab which can be literal or escaped) + #for example - can be used by from_dict to produce valid Bstring data for a tomlish record + proc rawstring_to_Bstring_with_escaped_controls {str} { + #for the well known chars that have compact escape sequences allowed by toml - we choose that form over the full \u form. + #we'll use a string map with an explicit list rather than algorithmic at runtime + # - the string map is probably more performant than splitting a string, especially if it's large + variable Bstring_control_map + return [string map $Bstring_control_map $str] + } + + #review - unescape what string? Bstring vs MLBstring? + #we should be specific in the function naming here + #used by to_dict - so part of validation? - REVIEW + proc unescape_string {str} { + #note we can't just use Tcl subst because: + # it also transforms \a (audible bell) and \v (vertical tab) which are not in the toml spec. + # it would strip out backslashes inappropriately: e.g "\j" becomes just j + # it recognizes other escapes which aren't approprite e.g \xhh and octal \nnn + # it replaces \ with a single whitespace (trailing backslash) + #This means we shouldn't use 'subst' on the whole string, but instead substitute only the toml-specified escapes (\r \n \b \t \f \\ \" \uhhhh & \Uhhhhhhhh + + set buffer "" + set buffer4 "" ;#buffer for 4 hex characters following a \u + set buffer8 "" ;#buffer for 8 hex characters following a \u + + set sLen [tcl::string::length $str] + + #we need to handle arbitrarily long sequences of backslashes. \\\\\ etc + set slash_active 0 + set unicode4_active 0 + set unicode8_active 0 + + ::tomlish::log::debug "unescape_string. got len [string length str] str $str" + + #!todo - check for invalid data in the form of a raw carriage return (decimal 13) without following linefeed? + set i 0 + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $str [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $str $i] + #::tomlish::log::debug "unescape_string. got char $c" ;#too much? + + #---------------------- + #as we are 'unescaping' - should we really be testing for existing values that should have been escaped? + #this test looks incomplete anyway REVIEW + scan $c %c n + if {($n <= 31) && ($n != 9) && ($n != 10) && ($n != 13)} { + #we don't expect unescaped unicode characters from 0000 to 001F - + #*except* for raw tab (which is whitespace) and newlines + error "unescape_string. Invalid data for a toml string. Unescaped control character (decimal $n) [::tomlish::utils::string_to_slashu $c]" + } + #---------------------- + + incr i ;#must incr here because we do'returns'inside the loop + if {$c eq "\\"} { + if {$slash_active} { + append buffer "\\" + set slash_active 0 + } elseif {$unicode4_active} { + error "unescape_string. unexpected case slash during unicode4 not yet handled" + } elseif {$unicode8_active} { + error "unescape_string. unexpected case slash during unicode8 not yet handled" + } else { + # don't output anything (yet) + set slash_active 1 + } + } else { + if {$unicode4_active} { + if {[tcl::string::length $buffer4] < 4} { + append buffer4 $c + } + if {[tcl::string::length $buffer4] == 4} { + #we have a \uHHHH to test + set unicode4_active 0 + set result [tomlish::utils::unicode_escape_info "\\u$buffer4"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$unicode8_active} { + if {[tcl::string::length $buffer8] < 8} { + append buffer8 $c + } + if {[tcl::string::length $buffer8] == 8} { + #we have a \UHHHHHHHH to test + set unicode8_active 0 + set result [tomlish::utils::unicode_escape_info "\\U$buffer8"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$slash_active} { + set slash_active 0 + set ctest [tcl::string::map {{"} dq} $c] + switch -exact -- $ctest { + dq { + set e "\\\"" + append buffer [subst -nocommand -novariable $e] + } + b - t - n - f - r { + set e "\\$c" + append buffer [subst -nocommand -novariable $e] + } + u { + set unicode4_active 1 + set buffer4 "" + } + U { + set unicode8_active 1 + set buffer8 "" + } + default { + set slash_active 0 + #review - toml spec says all other escapes are reserved + #and if they are used TOML should produce an error. + #we leave detecting this for caller for now - REVIEW + append buffer "\\" + append buffer $c + } + } + } else { + append buffer $c + } + } + } + #puts stdout "EOF 4:$unicode4_active 8:$unicode8_active slash:$slash_active" + if {$unicode4_active} { + error "End of string reached before complete unicode escape sequence \uHHHH" + } + if {$unicode8_active} { + error "End of string reached before complete unicode escape sequence \UHHHHHHHH" + } + if {$slash_active} { + append buffer "\\" + } + return $buffer + } + + #This does not have to do with unicode normal forms - which it seems toml has decided against regarding use in keys (review/references?) + #This is meant for internal use regarding ensuring we match equivalent keys which may have just been specified with different string mechanisms, + #e.g squoted vs dquoted vs barekey. + proc normalize_key {rawkey} { + set c1 [tcl::string::index $rawkey 0] + set c2 [tcl::string::index $rawkey end] + if {($c1 eq "'") && ($c2 eq "'")} { + #single quoted segment. No escapes allowed within it. + set key [tcl::string::range $rawkey 1 end-1] + } elseif {($c1 eq "\"") && ($c2 eq "\"")} { + #double quoted segment. Apply escapes. + # + set keydata [tcl::string::range $rawkey 1 end-1] ;#strip outer quotes only + #e.g key could have mix of \UXXXXXXXX escapes and unicode chars + #or mix of \t and literal tabs. + #unescape to convert all to literal versions for comparison + set key [::tomlish::utils::unescape_string $keydata] + #set key [subst -nocommands -novariables $keydata] ;#wrong. Todo - create a string escape substitution function. + } else { + set key $rawkey + } + return $key + } + + proc string_to_slashu {string} { + set rv {} + foreach c [split $string {}] { + scan $c %c cdec + if {$cdec > 65535} { + append rv {\U} [format %.8X $cdec] + } else { + append rv {\u} [format %.4X $cdec] + } + } + return $rv + } + + #'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. + #This is used for display purposes only (error msgs) + proc nonprintable_to_slashu {s} { + set res "" + foreach i [split $s ""] { + scan $i %c cdec + + set printable 0 + if {($cdec>31) && ($cdec<127)} { + set printable 1 + } + if {$printable} { + append res $i + } else { + if {$cdec > 65535} { + append res \\U[format %.8X $cdec] + } else { + append res \\u[format %.4X $cdec] + } + } + } + set res + } ;# initial version from tcl wiki RS + + #check if str is valid for use as a toml bare key + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } else { + set matches [regexp -all {[a-zA-Z0-9\_\-]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters match the regexp + return 1 + } else { + return 0 + } + } + } + + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + + #test only that the characters in str are valid for the toml specified type 'integer'. + proc int_validchars1 {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_\-\+]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + #add support for hex,octal,binary 0x.. 0o.. 0b... + proc int_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_int {str} { + set matches [regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + + # --------------------------------------- + #check for leading zeroes in non 0x 0b 0o + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + if {([tcl::string::length $check] > 1) && ([tcl::string::index $check 0] eq "0") && ([tcl::string::index $check 1] ni {o x b})} { + return 0 + } + # --------------------------------------- + + #check +,- only occur in the first position. + if {[tcl::string::last - $str] > 0} { + return 0 + } + if {[tcl::string::last + $str] > 0} { + return 0 + } + set numeric_value [tcl::string::map {_ ""} $str] ;#allow some earlier tcl versions which don't support underscores + #use Tcl's integer check to ensure we don't let things like 3e4 through - which is a float (would need to be 0x3e4 for hex) + if {![tcl::string::is integer -strict $numeric_value]} { + return 0 + } + #!todo - check bounds only based on some config value + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements. + #presumably very large numbers would have to be supplied in a toml file as strings. + #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max + if {$numeric_value > $::tomlish::max_int} { + return 0 + } + if {$numeric_value < $::tomlish::min_int} { + return 0 + } + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'float'. + proc float_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[eE0-9\_\-\+\.]} $str] == $numchars} { + return 1 + } else { + #only allow lower case for these special values - as per Toml 1.0 spec + if {$str ni {inf +inf -inf nan +nan -nan}} { + return 0 + } else { + return 1 + } + } + } + + proc is_float {str} { + set matches [regexp -all {[eE0-9\_\-\+\.]} $str] + #don't test for case variations - as Toml doesn't allow (whereas Tcl allows Inf NaN etc) + if {$str in {inf +inf -inf nan +nan -nan}} { + return 1 + } + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + #A leading zero is ok, but we should disallow multiple leading zeroes (same rules as toml ints) + #Toml spec also disallows leading zeros in the exponent part + #... but this seems less interoperable (some libraries generate leading zeroes in exponents) + #for now we will allow leading zeros in exponents + #!todo - configure 'strict' option to disallow? + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + set r {([0-9])*} + regexp $r $check intpart ;#intpart holds all numerals before the first .,e or E + set z {([0])*} + regexp $z $intpart leadingzeros + if {[tcl::string::length $leadingzeros] > 1} { + return 0 + } + #for floats, +,- may occur in multiple places + #e.g -2E-22 +3e34 + #!todo - check bounds ? + + #strip underscores for tcl double check + set check [tcl::string::map {_ ""} $str] + #string is double accepts inf nan +NaN etc. + if {![tcl::string::is double $check]} { + return 0 + } + + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'datetime'. + proc datetime_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[zZtT0-9\-\+\.:]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + #review - we + proc is_datetime {str} { + #e.g 1979-05-27 + #e.g 1979-05-27T00:32:00Z + #e.g 1979-05-27 00:32:00-07:00 + #e.g 1979-05-27 00:32:00+10:00 + #e.g 1979-05-27 00:32:00.999999-07:00 + + #review + #minimal datetimes? + # 2024 ok - shortest valid 4 digit year? + # 02:00 ok + # 05-17 ok + if {[string length $str] < 4} { + return 0 + } + + set matches [regexp -all {[zZtT0-9\-\+\.:]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + #!todo - use full RFC 3339 parser? + lassign [split $str T] datepart timepart + #!todo - what if the value is 'time only'? + + #Tcl's free-form clock scan (no -format option) is deprecated + # + #if {[catch {clock scan $datepart} err]} { + # puts stderr "tcl clock scan failed err:'$err'" + # return 0 + #} + + #!todo - verify time part is reasonable + } else { + return 0 + } + return 1 + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::utils ---}] +} + +namespace eval tomlish::parse { + #*** !doctools + #[subsection {Namespace tomlish::parse}] + #[para] + #[list_begin definitions] + + #This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases. + #The code is a pig's-nest - but it should be noted that for example trailing single double quotes in multiline strings are perhaps not so trivial to parse using more standard methods either: + # - e.g some kind of backtracking required if using an ABNF parser? + #I don't know the precise technical name for this sort of parser; probably something like "Dog's Breakfast" + #More seriously, we don't have distinct lex/parse steps - so it is basically a 'fused lexer' or 'scannerless parser' + + #It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? + + #A possible alternative more structured approach might be to use a PEG (Parsing Expression Grammar) + + + variable is_parsing 0 ;#whether we are in the middle of parsing tomlish text + + variable state + # states: + # table-space, itable-space, array-space + # value-expected, keyval-syntax, + # quoted-key, squoted-key + # string-state, literal-state, multistring... + # + # notes: + # only the -space states are also 'spaces' ie a container which is pushed/popped on the spacestack + + # + # value-expected - we also allow for leading whitespace in this state, but once a value is returned we jump to a state based on the containing space. e.g keyval-tail or array-syntax + # + #stateMatrix defines for each state, actions to take for each possible token. + #single-element actions are the name of the next state into which to transition, or a 'POPSPACE' instruction to pop a level off the spacestack and add the data to the parent container. + #dual-element actions are a push instruction and the name of the space to push on the stack. + # - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) + + # -- --- --- --- --- --- + #token/state naming guide + # -- --- --- --- --- --- + #tokens : underscore separated or bare name e.g newline, start_quote, start_squote + #private tokens: always have a leading underscore (These are private 'temporary state' tokens that are never returned as actual tokens e.g _start_squote_sequence + #states : always contain at least one dash e.g err-state, table-space + #instructions + # -- --- --- --- --- --- + + + #stateMatrix dict of elements mapping current state to next state based on returned tokens + # current-state {token-encountered next-state ... } + # where next-state can be a 1 or 2 element list. + #If 2 element - the first item is an instruction (ucase) + #If 1 element - it is either a lowercase dashed state name or an ucase instruction + #e.g {PUSHSPACE } or POPSPACE or SAMESPACE + + + #SAMESPACE - got to same space as parent without popping a level, but has it's own autotransition lookup - strange concept - review usecases + + variable stateMatrix + set stateMatrix [dict create] + + #xxx-space vs xxx-syntax inadequately documented - TODO + + # --------------------------------------------------------------------------------------------------------------# + # incomplete example of some state starting at table-space + # --------------------------------------------------------------------------------------------------------------# + # ( = -> value-expected) + # keyval-syntax (popped -> keyval-space -> keyval-tail) (autotransition on pop) + # keyval-space (autotransition on push ^) + # table-space (barekey^) (startdquote -> dquoted-key ^) + # --------------------------------------------------------------------------------------------------------------# + + dict set stateMatrix\ + table-space { + bom "table-space"\ + whitespace "table-space"\ + newline "table-space"\ + barekey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + squotedkey {PUSHSPACE "keyval-space" state "keyval-syntax" note ""}\ + dquotedkey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + XXXstartquote "quoted-key"\ + XXXstartsquote "squoted-key"\ + comment "table-space"\ + starttablename "tablename-state"\ + starttablearrayname "tablearrayname-state"\ + startmultiquote "err-state"\ + endquote "err-state"\ + comma "err-state"\ + eof "end-state"\ + equal "err-state"\ + cr "err-lonecr"\ + } + + #itable-space/ curly-syntax : itables + dict set stateMatrix\ + itable-space {\ + whitespace "itable-space"\ + newline "itable-space"\ + barekey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + dquotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + endinlinetable "POPSPACE"\ + XXXstartquote "quoted-key"\ + XXXstartsquote {TOSTATE "squoted-key" comment "jn-testing"}\ + comma "err-state"\ + comment "itable-space"\ + eof "err-state"\ + } + #squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-space starttok {squote_seq "'"}} + + + dict set stateMatrix\ + keyval-space {\ + whitespace "keyval-syntax"\ + equal "keyval-value-expected"\ + } + + # ' = ' portion of keyval + dict set stateMatrix\ + keyval-syntax {\ + whitespace "keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "keyval-value-expected"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + #### + dict set stateMatrix\ + keyval-value-expected {\ + whitespace "keyval-value-expected"\ + untyped_value {TOSTATE "keyval-tail" note ""}\ + squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate keyval-value-expected starttok {squote_seq "'"}}\ + startquote {TOSTATE "string-state" returnstate keyval-tail}\ + startmultiquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + startsquote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + double_squote {TOSTATE "keyval-tail" note "empty literal received when double squote occurs"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + } + #squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate keyval-process-leading-squotes starttok {squote_seq "'"}} + dict set stateMatrix\ + leading-squote-space {\ + squote_seq "POPSPACE"\ + } + #dict set stateMatrix\ + # keyval-process-leading-squotes {\ + # startsquote "literal-state"\ + # triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + # } + + dict set stateMatrix\ + keyval-tail {\ + whitespace "keyval-tail"\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + dict set stateMatrix\ + itable-keyval-syntax {\ + whitespace "itable-keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "itable-keyval-value-expected"\ + newline "err-state"\ + eof "err-state"\ + } + dict set stateMatrix\ + itable-keyval-value-expected {\ + whitespace "itable-keyval-value-expected"\ + untyped_value {TOSTATE "itable-val-tail" note ""}\ + squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-keyval-value-expected starttok {squote_seq "'"}}\ + startquote {TOSTATE "string-state" returnstate itable-val-tail}\ + startmultiquote {PUSHSPACE "multistring-space" returnstate itable-val-tail}\ + startsquote {TOSTATE "literal-state" returnstate itable-val-tail note "usual way a literal is triggered"}\ + double_squote {TOSTATE "itable-val-tail" note "empty literal received when double squote occurs"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate itable-val-tail}\ + startinlinetable {PUSHSPACE "itable-space" returnstate itable-val-tail}\ + startarray {PUSHSPACE "array-space" returnstate itable-val-tail}\ + } + dict set stateMatrix\ + itable-keyval-space {\ + whitespace "itable-keyval-syntax"\ + equal {TOSTATE "itable-keyval-value-expected" note "required"}\ + } + + dict set stateMatrix\ + itable-val-tail {\ + whitespace "itable-val-tail"\ + endinlinetable "POPSPACE"\ + comma "POPSPACE"\ + XXXnewline {TOSTATE "itable-val-tail" note "itable-space ??"}\ + newline "POPSPACE"\ + comment "itable-val-tail"\ + eof "err-state"\ + } + #dict set stateMatrix\ + # itable-quoted-key {\ + # whitespace "NA"\ + # itablequotedkey {PUSHSPACE "itable-keyval-space"}\ + # newline "err-state"\ + # endquote "itable-keyval-syntax"\ + # } + #dict set stateMatrix\ + # itable-squoted-key {\ + # whitespace "NA"\ + # itablesquotedkey {PUSHSPACE "itable-keyval-space"}\ + # newline "err-state"\ + # endsquote "itable-keyval-syntax"\ + # } + + + + + + dict set stateMatrix\ + value-expected {\ + whitespace "value-expected"\ + untyped_value {"SAMESPACE" "" replay untyped_value}\ + startquote "string-state"\ + startsquote "literal-state"\ + startmultiquote {PUSHSPACE "multistring-space"}\ + triple_squote {PUSHSPACE "multiliteral-space"}\ + startinlinetable {PUSHSPACE itable-space}\ + startarray {PUSHSPACE array-space}\ + comment "err-state-value-expected-got-comment"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + + #dottedkey-space is not (currently) used within [tablename] or [[tablearrayname]] + #it is for keyval ie x.y.z = value + + #this is the state after dot + #we are expecting a complete key token or whitespace + #(initial entry to the space is by one of the keys - which will immediately go to dottedkey-space-tail) + dict set stateMatrix\ + dottedkey-space {\ + whitespace "dottedkey-space"\ + dotsep "err-state"\ + barekey "dottedkey-space-tail"\ + squotedkey "dottedkey-space-tail"\ + dquotedkey "dottedkey-space-tail"\ + newline "err-state"\ + comma "err-state"\ + comment "err-state"\ + equal "err-state"\ + } + #dottedkeyend "POPSPACE" + #equal "POPSPACE"\ + + #jmn 2025 + #we have 1 or more dottedkeys so far - need dotsep to add more, whitespace to maintain, equal to pop + dict set stateMatrix\ + dottedkey-space-tail {\ + whitespace "dottedkey-space-tail" + dotsep "dottedkey-space" + equal "POPSPACE"\ + } + + #-------------------------------------------------------------------------- + #scratch area + #from_toml {x=1} + # barekey tok + # table-space PUSHSPACE keyval-space state keyval-syntax + # + + + #-------------------------------------------------------------------------- + + + #REVIEW + #toml spec looks like heading towards allowing newlines within inline tables + #https://github.com/toml-lang/toml/issues/781 + + #2025 - appears to be valid for 1.1 - which we are targeting. + #https://github.com/toml-lang/toml/blob/main/toml.md#inline-table + + #JMN2025 + #dict set stateMatrix\ + # curly-syntax {\ + # whitespace "curly-syntax"\ + # newline "curly-syntax"\ + # barekey {PUSHSPACE "itable-keyval-space"}\ + # itablequotedkey "itable-keyval-space"\ + # endinlinetable "POPSPACE"\ + # startquote "itable-quoted-key"\ + # comma "itable-space"\ + # comment "itable-space"\ + # eof "err-state"\ + # } + #review comment "err-state" vs comment "itable-space" - see if TOML 1.1 comes out and allows comments in multiline ITABLES + #We currently allow multiline ITABLES (also with comments) in the tokenizer. + #if we want to disallow as per TOML 1.0 - we should do so when attempting to get structure? + + + #JMN REVIEW + dict set stateMatrix\ + array-space {\ + whitespace "array-space"\ + newline "array-space"\ + untyped_value "SAMESPACE"\ + startarray {PUSHSPACE "array-space"}\ + endarray "POPSPACE"\ + startmultiquote {PUSHSPACE multistring-space}\ + startinlinetable {PUSHSPACE itable-space}\ + startquote "string-state"\ + startsquote "literal-state"\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax note "seems ok 2024"}\ + comma "array-space"\ + comment "array-space"\ + eof "err-state-array-space-got-eof"\ + } + dict set stateMatrix\ + array-syntax {\ + whitespace "array-syntax"\ + newline "array-syntax"\ + untyped_value "SAMESPACE"\ + startarray {PUSHSPACE array-space}\ + endarray "POPSPACE"\ + startmultiquote {PUSHSPACE multistring-space}\ + startquote "string-state"\ + startsquote "literal-state"\ + comma "array-space"\ + comment "err-state"\ + } + + + + #quoted-key & squoted-key need to PUSHSPACE from own token to keyval-space + dict set stateMatrix\ + quoted-key {\ + whitespace "NA"\ + dquotedkey {PUSHSPACE "keyval-space"}\ + newline "err-state"\ + endquote "keyval-syntax"\ + } + + + #review + dict set stateMatrix\ + dquoted-key {\ + whitespace "NA"\ + dquotedkey "dquoted-key"\ + newline "err-state"\ + } + dict set stateMatrix\ + squoted-key {\ + whitespace "NA"\ + squotedkey "squoted-key"\ + newline "err-state"\ + } + # endsquote {PUSHSPACE "keyval-space"} + + dict set stateMatrix\ + string-state {\ + whitespace "NA"\ + string "string-state"\ + endquote "SAMESPACE"\ + newline "err-state"\ + eof "err-state"\ + } + dict set stateMatrix\ + literal-state {\ + whitespace "NA"\ + literal "literal-state"\ + endsquote "SAMESPACE"\ + newline "err-state"\ + eof "err-state"\ + } + + + #dict set stateMatrix\ + # stringpart {\ + # continuation "SAMESPACE"\ + # endmultiquote "POPSPACE"\ + # eof "err-state"\ + # } + dict set stateMatrix\ + multistring-space {\ + whitespace "multistring-space"\ + continuation "multistring-space"\ + stringpart "multistring-space"\ + newline "multistring-space"\ + endmultiquote "POPSPACE"\ + eof "err-state"\ + } + + + #only valid subparts are literalpart and newline. other whitespace etc is within literalpart + #todo - treat sole cr as part of literalpart but crlf and lf as newline + dict set stateMatrix\ + multiliteral-space {\ + literalpart "multiliteral-space"\ + newline "multiliteral-space"\ + squote_seq_begin {PUSHSPACE "trailing-squote-space" returnstate multiliteral-space starttok {squote_seq "'"}}\ + triple_squote {POPSPACE note "on popping - we do any necessary concatenation of LITERALPART items due to squote processing"}\ + double_squote {TOSTATE multiliteral-space note "short squote_seq: can occur anywhere in the space e.g emitted at end when 5 squotes occur"}\ + startsquote {TOSTATE multiliteral-space note "short squote_seq: same as double_squote - false alarm"}\ + eof "err-premature-eof-in-multiliteral-space"\ + } + + #trailing because we are looking for possible terminating ''' - but must accept '''' or ''''' and re-integrate the 1st one or 2 extra squotes + dict set stateMatrix\ + trailing-squote-space {\ + squote_seq "POPSPACE"\ + } + + + dict set stateMatrix\ + tablename-state {\ + whitespace "NA"\ + tablename {zeropoppushspace table-space}\ + tablename2 {PUSHSPACE table-space}\ + endtablename "tablename-tail"\ + comma "err-state"\ + newline "err-state"\ + } + dict set stateMatrix\ + tablearrayname-state {\ + whitespace "NA"\ + tablearrayname {zeropoppushspace table-space}\ + tablearrayname2 {PUSHSPACE table-space}\ + endtablearray "tablearrayname-tail"\ + comma "err-state"\ + newline "err-state"\ + } + + dict set stateMatrix\ + tablename-tail {\ + whitespace "tablename-tail"\ + newline "table-space"\ + comment "tablename-tail"\ + eof "end-state"\ + } + dict set stateMatrix\ + tablearrayname-tail {\ + whitespace "tablearrayname-tail"\ + newline "table-space"\ + comment "tablearrayname-tail"\ + eof "end-state"\ + } + dict set stateMatrix\ + end-state {} + + set knowntokens [list] + set knownstates [list] + dict for {state transitions} $stateMatrix { + if {$state ni $knownstates} {lappend knownstates $state} + dict for {tok instructions} $transitions { + if {$tok ni $knowntokens} {lappend knowntokens $tok} + } + } + dict set stateMatrix nostate {} + foreach tok $knowntokens { + dict set stateMatrix nostate $tok "err-nostate-received-token-$tok" + } + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #purpose - debugging? remove? + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #build a list of 'push triggers' from the stateMatrix + # ie tokens which can push a new space onto spacestack + set push_trigger_tokens [list] + tcl::dict::for {s transitions} $stateMatrix { + tcl::dict::for {token transition_to} $transitions { + set instruction [lindex $transition_to 0] + switch -exact -- $instruction { + PUSHSPACE - zeropoppushspace { + if {$token ni $push_trigger_tokens} { + lappend push_trigger_tokens $token + } + } + } + } + } + ::tomlish::log::debug "push_trigger_tokens: $push_trigger_tokens" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + + #This seems hacky... (deprecate in favour of explicit arguments to the instructions in stateMatrix?) + #spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE + + #mainly for the -space states: + #redirect to another state $c based on a state transition from $whatever to $b + # e.g "string {array-space array-syntax}" means when transitioning from string to array-space, jump to array-syntax instead. + #this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' + + #Push to, next + #default first states when we push to these spaces + variable spacePushTransitions { + keyval-space keyval-syntax + itable-keyval-space itable-keyval-syntax + array-space array-space + table-space tablename-state + } + #itable-space itable-space + #Pop to, next + variable spacePopTransitions { + array-space array-syntax + } + #itable-space curly-syntax + #itable-keyval-space itable-val-tail + #review + #we pop to keyval-space from dottedkey-space or from value-expected? we don't always want to go to keyval-tail + #leave it out and make the POPSPACE caller explicitly specify it + #keyval-space keyval-tail + + variable spaceSameTransitions { + array-space array-syntax + } + #itable-space curly-syntax + #itable-keyval-space itable-val-tail + + + variable state_list ;#reset every tomlish::decode::toml + + namespace export tomlish toml + namespace ensemble create + + #goNextState has various side-effects e.g pushes and pops spacestack + #REVIEW - setting nest and v elements here is ugly + #todo - make neater, more single-purpose? + proc goNextState {tokentype tok currentstate} { + variable state + variable nest + variable v + + set prevstate $currentstate + + + variable spacePopTransitions + variable spacePushTransitions + variable spaceSameTransitions + + variable last_space_action "none" + variable last_space_type "none" + variable state_list + + set result "" + set starttok "" + + if {[dict exists $::tomlish::parse::stateMatrix $currentstate $tokentype]} { + set transition_to [dict get $::tomlish::parse::stateMatrix $currentstate $tokentype] + ::tomlish::log::debug "--->> goNextState tokentype:$tokentype tok:$tok currentstate:$currentstate : transition_to = $transition_to" + switch -exact -- [lindex $transition_to 0] { + POPSPACE { + spacestack pop + set parent_info [spacestack peek] + set type [dict get $parent_info type] + set parentspace [dict get $parent_info state] + + set last_space_action "pop" + set last_space_type $type + + if {[dict exists $parent_info returnstate]} { + set next [dict get $parent_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace redirected to stored returnstate $next <<---" + } else { + ### + #review - do away with spacePopTransitions - which although useful to provide a default.. + # - involve error-prone configurations distant to the main state transition configuration in stateMatrix + if {[dict exists $::tomlish::parse::spacePopTransitions $parentspace]} { + set next [dict get $::tomlish::parse::spacePopTransitions $parentspace] + ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace redirected state to $next (spacePopTransitions)<<---" + } else { + set next $parentspace + ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace<<---" + } + } + set result $next + } + SAMESPACE { + set currentspace_info [spacestack peek] + ::tomlish::log::debug "--->> SAMESPACE got current space entry: $currentspace_info <<<<<" + set type [dict get $currentspace_info type] + set currentspace [dict get $currentspace_info state] + + if {[dict exists $currentspace_info returnstate]} { + set next [dict get $currentspace_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected to stored returnstate $next" + } else { + if {[dict exists $::tomlish::parse::spaceSameTransitions $currentspace]} { + set next [dict get $::tomlish::parse::spaceSameTransitions $currentspace] + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected state to $next (spaceSameTransitions)" + } else { + set next $currentspace + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace" + } + } + set result $next + } + zeropoppushspace { + if {$nest > 0} { + #pop back down to the root level (table-space) + spacestack pop + set parentinfo [spacestack peek] + set type [dict get $parentinfo type] + set target [dict get $parentinfo state] + + set last_space_action "pop" + set last_space_type $type + + #----- + #standard pop + set parentlevel [expr {$nest -1}] + lappend v($parentlevel) [set v($nest)] + incr nest -1 + #----- + } + #re-entrancy + + #set next [list PUSHSPACE [lindex $transition_to 1]] + set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 + #::tomlish::log::notice "goNextState REENTRANCY. calling goNextState $nexttokentype $tokentype" + #set result [::tomlish::parse::goNextState $nexttokentype $tokentype] + ::tomlish::log::debug "--->> zeropoppushspace goNextState REENTRANCY. calling goNextState $nexttokentype $currentstate" + set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] + set result [dict get $transition_info newstate] + } + PUSHSPACE { + set original_target [dict get $transition_to PUSHSPACE] + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + if {[dict exists $transition_to starttok]} { + set starttok [dict get $transition_to starttok] + } + spacestack push [dict create type space state $original_target] + + set last_space_action "push" + set last_space_type "space" + + if {[dict exists $transition_to state]} { + #an explicit state in the pushed space was requested in the stateMatrix - override the spacePushTransition (spacePushTransitions can be deprecated if we require explicitness?) + set next [dict get $transition_to state] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next by explicit 'state' entry" + } else { + #puts $::tomlish::parse::spacePushTransitions + if {[dict exists $::tomlish::parse::spacePushTransitions $original_target]} { + set next [dict get $::tomlish::parse::spacePushTransitions $original_target] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next (spacePushTransitions) " + } else { + set next $original_target + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target" + } + } + set result $next + } + TOSTATE { + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + set result [dict get $transition_to TOSTATE] + } + default { + #simplified version of TOSTATE + set result [lindex $transition_to 0] ;#ignore everything but first word + } + } + } else { + ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" + set result "nostate" + } + lappend state_list [list tokentype $tokentype from $currentstate to $result] + set state $result + ::tomlish::log::notice "--->> STATE TRANSITION tokenType: '$tokentype' tok:$tok triggering '$currentstate' -> '$result' last_space_action:$last_space_action " + return [dict create prevstate $prevstate newstate $result space_action $last_space_action starttok $starttok] + } + + proc report_line {{line ""}} { + variable linenum + variable is_parsing + if {$is_parsing} { + if {$line eq ""} { + set line $linenum + } + return "Line Number: $line" + } else { + #not in the middle of parsing tomlish text - return nothing. + return "" + } + } + + #produce a *slightly* more readable string rep of the nest for puts etc. + proc nest_pretty1 {list} { + set prettier "{" + + foreach el $list { + if { [lindex $el 0] eq "NEWLINE"} { + append prettier "[list $el]\n" + } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY DQKEY SQKEY TABLE ARRAY})} { + append prettier [nest_pretty1 $el] + } else { + append prettier "[list $el] " + } + } + append prettier "}" + return $prettier + } + + proc set_tokenType {t} { + variable tokenType + variable tokenType_list + if {![info exists tokenType]} { + set tokenType "" + } + lappend tokenType_list $t + set tokenType $t + } + + proc switch_tokenType {t} { + variable tokenType + variable tokenType_list + lset tokenType_list end $t + set tokenType $t + } + + proc get_tokenType {} { + variable tokenType + return $tokenType + } + + proc _shortcircuit_startquotesequence {} { + variable tok + variable i + set toklen [tcl::string::length $tok] + if {$toklen == 1} { + set_tokenType "startquote" + incr i -1 + return -level 2 1 + } elseif {$toklen == 2} { + puts stderr "_shortcircuit_startquotesequence toklen 2" + set_tokenType "startquote" + set tok "\"" + incr i -2 + return -level 2 1 + } + } + + proc get_token_waiting {} { + variable token_waiting + return [lindex $token_waiting 0] + } + proc clear_token_waiting {} { + variable token_waiting + set token_waiting [list] + } + + #token_waiting is a list - but our standard case is to have only one + #in certain circumstances such as near eof we may have 2 + #the set_token_waiting function only allows setting when there is not already one waiting. + #we want to catch cases of inadvertently trying to set multiple + # - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. + proc set_token_waiting {args} { + if {[llength $args] %2 != 0} { + error "tomlish set_token_waiting must have args of form: type value complete 0|1" + } + variable token_waiting + + if {[llength $token_waiting] && [dict get [lindex $token_waiting end] type] ne "eof"} { + #tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another + #we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context + #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it + set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" + append err \n " - cannot add token_waiting: $args" + error $err + #set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] + #set token_waiting [list] + } + + set waiting [dict create] + dict for {k v} $args { + switch -exact $k { + type - complete { + dict set waiting $k $v + } + value { + dict set waiting tok $v + } + startindex { + dict set waiting startindex $v + } + default { + error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" + } + } + } + if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { + error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" + } + if {![llength $token_waiting]} { + set token_waiting [list $waiting] + } else { + #an extra sanity-check that we don't have more than just the eof.. + if {[llength $token_waiting] > 1} { + set err "tomlish Unexpected. Existing token_waiting count > 1.\n" + foreach tw $token_waiting { + append err " $tw" \n + } + append err " - cannot add token_waiting: $waiting" + error $err + } + #last entry must be a waiting eof + set token_waiting [list $waiting [lindex $token_waiting end]] + } + return + } + + #returns 0 or 1 + #tomlish::parse::tok + #we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag + # - the possible benefit is being able to more easily process in arbitrarily split chunks (although we would still have to watch crlf splitting ?) + # - interactive use? + + proc tok {s} { + variable nest + variable v + variable i + variable tok + variable type ;#character type + variable state ;#FSM + + + variable tokenType + variable tokenType_list + + + variable endToken + + variable lastChar + + variable braceCount + variable bracketCount + + + #------------------------------ + #Previous run found another (presumably single-char) token + #The normal case is for there to be only one dict in the list + #multiple is an exception - primarily for eof + variable token_waiting + if {[llength $token_waiting]} { + set waiting [lindex $token_waiting 0] + + set tokenType [dict get $waiting type] + set tok [dict get $waiting tok] + #todo: dict get $token_waiting complete + set token_waiting [lrange $token_waiting 1 end] + return 1 + } + #------------------------------ + + set resultlist [list] + set sLen [tcl::string::length $s] + + set slash_active 0 + set quote 0 + set c "" + set multi_dquote "" + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $s [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $s $i] + set cindex $i + set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] + tomlish::log::debug "- tokloop char <$ctest> index $i tokenType:$tokenType tok:<$tok>" + #puts "got char $c during tokenType '$tokenType'" + incr i ;#must incr here because we do returns inside the loop + + switch -exact -- $ctest { + # { + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {$had_slash} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + barekey { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" + } + whitespace { + # hash marks end of whitespace token + #do a return for the whitespace, set token_waiting + #set_token_waiting type comment value "" complete 1 + incr i -1 ;#leave comment for next run + return 1 + } + untyped_value { + #REVIEW! the spec isn't clear.. is whitespace after an int,bool etc required before comment? + #we will accept a comment marker as an immediate terminator of the untyped_value. + incr i -1 + return 1 + } + starttablename - starttablearrayname { + #fix! + error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out + append tok $c + } + default { + #dquotedkey, itablequotedkey, string,literal, multistring + append tok $c + } + } + } else { + switch -- $state { + multistring-space { + set_tokenType stringpart + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes#" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "#" + } + default { + #start of token if we're not in a token + set_tokenType comment + set tok "" ;#The hash is not part of the comment data + } + } + } + } + lc { + #left curly brace + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + starttablename - starttablearrayname { + #*bare* tablename can only contain letters,digits underscores + error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #valid in quoted parts + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + switch -exact -- $state { + itable-keyval-value-expected - keyval-value-expected - value-expected { + #switch last key to tablename?? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + array-space - array-syntax { + #nested anonymous inline table + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\{" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\{" + } + default { + error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" + } + } + } + + } + rc { + #right curly brace + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey - comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + starttablename - tablename { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endinlinetable value "" complete 1 startindex $cindex + return 1 + } + starttablearrayname - tablearrayname { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + #end any other token + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + value-expected { + #invalid - but allow parser statemachine to report it. + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-space { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname-state problem" + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + #invalid + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + XXXcurly-syntax { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-val-tail { + set_tokenType "endinlinetable" + set tok "" + #we need to pop the keyval - and then reprocess to pop the inlinetable - so we incr -1 + incr i -1 + return 1 + } + itable-keyval-syntax { + error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\}" + } + multiliteral-space { + set_tokenType "literalpart" ; #review + set tok "\}" + } + default { + #JMN2024b keyval-tail? + error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" + } + } + } + + } + lb { + #left square bracket + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + starttablename { + #change the tokenType + switch_tokenType "starttablearrayname" + set tok "" ;#no output into the tomlish list for this token + #any following whitespace is part of the tablearrayname, so return now + return 1 + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + #append tok "\\[" + append tok {\[} + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + #invalid at this point - state machine should disallow table -> starttablearrayname + set_token_waiting type starttablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "\[" + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + keyval-value-expected - itable-keyval-value-expected - value-expected { + set_tokenType "startarray" + set tok "\[" + return 1 + } + table-space { + #table name + #assume it's a single bracket - but we need to wait for non-bracket to confirm it's not a tablearray + #note that a starttablearrayname token may contain whitespace between the brackets + # e.g \[ \[ + set_tokenType "starttablename" + set tok "" ;#there is no output into the tomlish list for this token + } + array-space - array-syntax { + #nested array? + set_tokenType "startarray" + set tok "\[" + return 1 + #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\[" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\[" + } + itable-space { + #handle state just to give specific error msg + error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[\] syntax. [tomlish::parse::report_line]" + } + default { + error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + rb { + #right square bracket + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + #???? + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } else { + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablename value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + tablearraynames { + #todo? + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + value-expected { + #invalid - but allow parser statemachine to report it. + set_tokenType "endarray" + set tok "\]" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endarray" + set tok "\]" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endtablename" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname problem" + set_tokenType "endtablearray" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + set_tokenType "endarray" + set tok "\]" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\]" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\]" + } + default { + error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + bsl { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + #backslash + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + #end whitespace token + incr i -1 ;#reprocess bsl in next run + return 1 + } else { + error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" + } + } + literal - literalpart - squotedkey { + #never need to set slash_active true when in single quoted tokens + append tok "\\" + set slash_active 0 + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey - comment { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + stringpart { + if {$slash_active} { + #assert - quotes empty - or we wouldn't have slash_active + set slash_active 0 + append tok "\\\\" + } else { + append tok $dquotes + set slash_active 1 + } + } + starttablename - starttablearrayname { + error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" + } + tablename - tablearrayname { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + barekey { + error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" + } + default { + error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$slash_active} { + set_tokenType "stringpart" + set tok "\\\\" + set slash_active 0 + } else { + if {$dquotes ne ""} { + set_tokenType "stringpart" + set tok $dquotes + } + set slash_active 1 + } + } + multiliteral-space { + #nothing can be escaped in multiliteral-space - not even squotes (?) review + set_tokenType "literalpart" + set tok "\\" + } + default { + error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" + } + } + } + } + sq { + #single quote + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + #short squote_seq tokens are returned if active during any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + switch -- $state { + leading-squote-space { + append tok $c + if {$existingtoklen > 2} { + error "tomlish tok error: squote_seq unexpected length $existingtoklen when another received" + } elseif {$existingtoklen == 2} { + return 1 ;#return tok ''' + } + } + trailing-squote-space { + append tok $c + if {$existingtoklen == 4} { + #maxlen to be an squote_seq is multisquote + 2 = 5 + #return tok ''''' + return 1 + } + } + default { + error "tomlish tok error: squote_seq in unexpected state '$state' - expected leading-squote-space or trailing-squote-space" + } + } + } + whitespace { + #end whitespace + incr i -1 ;#reprocess sq + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + #temp token creatable only during value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + append tok $c + } + 2 { + #switch? + append tok $c + set_tokenType triple_squote + return 1 + } + default { + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" + } + } + } + literal { + #slash_active always false + #terminate the literal + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + literalpart { + #ended by ''' - but final could be '''' or ''''' (up to 2 squotes allowed directly before ending triple squote sequence) + #todo + # idea: end this literalpart (possibly 'temporarily') + # let the sq be reprocessed in the multiliteral-space to push an end-multiliteral-sequence to state stack + # upon popping end-multiliteral-sequence - stitch quotes back into this literalpart's token (if either too short - or a long ending sequence as shown above) + incr i -1 ;#throw the "'" back to loop - will be added to an squote_seq token for later processing + return 1 + } + XXXitablesquotedkey { + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + squotedkey { + ### + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + starttablename - starttablearrayname { + #!!! + incr i -1 + return 1 + } + tablename - tablearrayname { + append tok $c + } + barekey { + #not clear why o'shennanigan shouldn't be a legal barekey - but it seems not to be. + error "tomlish Unexpected single quote during barekey. [tomlish::parse::report_line]" + } + default { + append tok $c + } + } + } else { + switch -exact -- $state { + value-expected - array-space { + set_tokenType "_start_squote_sequence" + set tok "'" + } + itable-keyval-value-expected - keyval-value-expected { + set_tokenType "squote_seq_begin" + set tok "'" + return 1 + } + table-space { + #tests: squotedkey.test + set_tokenType "squotedkey" + set tok "" + } + itable-space { + #tests: squotedkey_itable.test + set_tokenType "squotedkey" + set tok "" + } + XXXitable-space { + #future - could there be multiline keys? + #this would allow arbitrary tcl dicts to be stored in toml + #probably unlikely - as it's perhaps not very 'minimal' or ergonomic for config files + set_tokenType "squote_seq_begin" + set tok "'" + return 1 + } + tablename-state { + #first char in tablename-state/tablearrayname-state + set_tokenType tablename + append tok "'" + } + tablearrayname-state { + set_tokenType tablearrayname + append tok "'" + } + literal-state { + tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?" + set_tokenType literal + incr -1 + return 1 + } + multistring-space { + error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" + } + multiliteral-space { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up an squote_seq to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "squote_seq_begin" + set tok "'" + return 1 + } + dottedkey-space { + set_tokenType squotedkey + } + default { + error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" + } + } + } + + } + dq { + #double quote + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + set toklen [tcl::string::length $tok] + if {$toklen == 1} { + append tok $c + } elseif {$toklen == 2} { + append tok $c + #switch vs set? + set_tokenType "startmultiquote" + return 1 + } else { + error "tomlish unexpected token length $toklen in 'startquotesequence'" + } + } + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + set_tokenType "startsquote" + incr i -1 + return 1 + } + 2 { + set_tokenType "startsquote" + incr i -2 + return 1 + } + default { + error "tomlish unexpected _start_squote_sequence length $toklen" + } + } + } + literal - literalpart { + append tok $c + } + string { + if {$had_slash} { + append tok "\\" $c + } else { + #unescaped quote always terminates a string? + set_token_waiting type endquote value "\"" complete 1 startindex $cindex + return 1 + } + } + stringpart { + #sub element of multistring + if {$had_slash} { + append tok "\\" $c + } else { + #incr i -1 + + if {$multi_dquote eq "\"\""} { + set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex -2}] + set multi_dquote "" + return 1 + } else { + append multi_dquote "\"" + } + } + } + whitespace { + switch -exact -- $state { + multistring-space { + #REVIEW + if {$had_slash} { + incr i -2 + return 1 + } else { + switch -- [tcl::string::length $multi_dquote] { + 2 { + set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex-2}] + set multi_dquote "" + return 1 + } + 1 { + incr i -2 + return 1 + } + 0 { + incr i -1 + return 1 + } + } + } + } + keyval-value-expected - value-expected { + #end whitespace token and reprocess + incr i -1 + return 1 + + #if {$multi_dquote eq "\"\""} { + # set_token_waiting type startmultiquote value "\"\"\"" complete 1 + # set multi_dquote "" + # return 1 + #} else { + # #end whitespace token and reprocess + # incr i -1 + # return 1 + #} + } + table-space - itable-space { + incr i -1 + return 1 + } + default { + set_token_waiting type startquote value "\"" complete 1 startindex $cindex + return 1 + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + XXXdquotedkey - XXXitablequotedkey { + if {$had_slash} { + append tok "\\" + append tok $c + } else { + set_token_waiting type endquote value "\"" complete 1 startindex $cindex + return 1 + } + } + dquotedkey { + ### + if {$had_slash} { + append tok "\\" + append tok $c + } else { + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + } + squotedkey { + append tok $c + } + tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + incr i -1 ;## + return 1 + } + default { + error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + #$slash_active not relevant when no tokenType + #token is string only if we're expecting a value at this point + switch -exact -- $state { + keyval-value-expected - value-expected - array-space { + #!? start looking for possible multistartquote + #set_tokenType startquote + #set tok $c + #return 1 + set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote + set tok $c + } + itable-keyval-value-expected { + #JMN 2025 - review + set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote + set tok $c + } + multistring-space { + #TODO - had_slash!!! + #REVIEW + if {$had_slash} { + set_tokenType "stringpart" + set tok "\\\"" + set multi_dquote "" + } else { + if {$multi_dquote eq "\"\""} { + tomlish::log::debug "- tokloop char dq ---> endmultiquote" + set_tokenType "endmultiquote" + set tok "\"\"\"" + return 1 + #set_token_waiting type endmultiquote value "\"\"\"" complete 1 + #set multi_dquote "" + #return 1 + } else { + append multi_dquote "\"" + } + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\"" + } + XXXtable-space { + set_tokenType "startquote" + set tok $c + return 1 + } + XXXitable-space { + set_tokenType "startquote" + set tok $c + } + table-space - itable-space { + set_tokenType "dquotedkey" + set tok "" + } + tablename-state { + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + dottedkey-space { + set_tokenType dquotedkey + set tok "" + + #only if complex keys become a thing + #set_tokenType dquote_seq_begin + #set tok $c + } + default { + error "tomlish Unexpected quote during state '$state' [tomlish::parse::report_line]" + } + } + } + } + = { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + #assertion had_slash 0, multi_dquote "" + append tok $c + } + string - comment - dquotedkey - itablequotedkey { + #for these tokenTypes an = is just data. + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + whitespace { + if {$state eq "multistring-space"} { + set backlen [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backlen + return 1 + } else { + set_token_waiting type equal value = complete 1 startindex $cindex + return 1 + } + } + barekey { + #set_token_waiting type equal value = complete 1 + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out + append tok $c + } + default { + error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok ${dquotes}= + } + multiliteral-space { + set_tokenType "literalpart" + set tok "=" + } + dottedkey-space { + set_tokenType "equal" + set tok "=" + return 1 + } + default { + set_tokenType "equal" + set tok = + return 1 + } + } + } + } + cr { + #REVIEW! + set dquotes $multi_dquote + set multi_dquote "" ;#!! + # \r carriage return + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #we have received a double cr + ::tomlish::log::warn "double cr - will generate cr token. needs testing" + set_tokenType "cr" ;#lone cr token will generally raise an error - but let state machine handle it + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal { + append tok $c + } + literalpart { + #part of MLL string (multi-line literal string) + #we need to split out crlf as a separate NEWLINE to be consistent + ::tomlish::log::warn "literalpart ended by cr - needs testing" + #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space + incr i -1 + return 1 + } + stringpart { + #stringpart is a part of MLB string (multi-line basic string) + #throw back the cr - if followed by lf it will become a {NEWLINE crlf} entry within the MULTISTRING list (e.g between STRINGPART entries) + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #could in theory be valid in quoted part of name + #review - might be better just to disallow here + append tok $c + } + whitespace { + #it should technically be part of whitespace if not followed by lf + #but outside of values we are also free to map it to be another NEWLINE instead? REVIEW + incr i -1 + return 1 + } + untyped_value { + incr i -1 + return 1 + } + default { + #!todo - error out if cr inappropriate for tokenType + append tok $c + } + } + } else { + #lf may be appended if next + #review - lone cr as newline? - this is uncommon - but so is lone cr in a string(?) + set_tokenType "newline" + set tok cr + } + } + lf { + # \n newline + set dquotes $multi_dquote + set multi_dquote "" ;#!! + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #review + #this lf is the trailing part of a crlf + append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal { + #nl is not allowed *within* a literal - require multiliteral syntax for any literal containing a newline ''' ''' + #even though we terminate the literal without the closing quote here - the token_waiting newline should trigger a state error + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + literalpart { + #we allow newlines - but store them within the multiliteral as their own element + #This is a legitimate end to the literalpart - but not the whole multiliteral + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + stringpart { + if {$dquotes ne ""} { + append tok $dquotes + incr i -1 + return 1 + } else { + if {$had_slash} { + #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) + set_token_waiting type continuation value \\ complete 1 startindex [expr {$cindex-1}] + incr i -1 + return 1 + } else { + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } + starttablename - tablename - tablearrayname - starttablearrayname { + error "tomlish Character is invalid in $tokenType. [tomlish::parse::report_line]" + } + default { + #newline ends all other tokens. + #note for string: we don't add (raw unescaped) newline to simple string. (must use multi-string for this) + #note for whitespace: + # we will use the convention that \n terminates the current whitespace even if whitespace follows + # ie whitespace is split into separate whitespace tokens at each newline + + #puts "-------------- newline lf during tokenType $tokenType" + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + if {$dquotes ne ""} { + #e.g one or 2 quotes just before nl + set_tokenType "stringpart" + set tok $dquotes + incr i -1 + return 1 + } + set_tokenType "newline" + set tok lf + return 1 + } + } + multiliteral-space { + #assert had_slash 0, multi_dquote "" + set_tokenType "newline" + set tok "lf" + return 1 + } + default { + #ignore slash? error? + set_tokenType "newline" + set tok lf + return 1 + } + } + #if {$had_slash} { + # #CONT directly before newline - allows strings_5_byteequivalent test to pass + # set_tokenType "continuation" + # set tok "\\" + # incr i -1 + # return 1 + #} else { + # set_tokenType newline + # set tok lf + # return 1 + #} + } + } + , { + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + comment - tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok , + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + #stringpart can have up to 2 quotes too + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + literal - literalpart - squotedkey { + #assert had_slash always 0, multi_dquote "" + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + set backlen [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backlen + return 1 + } else { + set_token_waiting type comma value "," complete 1 startindex $cindex + return 1 + } + } + default { + set_token_waiting type comma value "," complete 1 startindex $cindex + if {$had_slash} {append tok "\\"} + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "$dquotes," + } + multiliteral-space { + #assert had_slash 0, multi_dquote "" + set_tokenType "literalpart" + set tok "," + } + default { + set_tokenType "comma" + set tok "," + return 1 + } + } + } + } + . { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + comment - untyped_value { + if {$had_slash} {append tok "\\"} + append tok $c + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + literal - literalpart - squotedkey { + #assert had_slash always 0, multi_dquote "" + append tok $c + } + whitespace { + switch -exact -- $state { + multistring-space { + set backchars [expr {[tcl::string::length $dquotes] + 1}] + if {$had_slash} { + incr backchars 1 + } + incr i -$backchars + return 1 + } + xxxdottedkey-space { + incr i -1 + return 1 + } + dottedkey-space-tail { + incr i -1 + return 1 + } + default { + error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" + } + } + } + starttablename - starttablearrayname { + #This would correspond to an empty table name + error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #subtable - split later - review + append tok $c + } + barekey { + #e.g x.y = 1 + #we need to transition the barekey to become a structured table name ??? review + #x is the tablename y is the key + set_token_waiting type dotsep value "." complete 1 startindex $cindex + return 1 + } + default { + error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" + #set_token_waiting type period value . complete 1 + #return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "$dquotes." + } + multiliteral-space { + set_tokenType "literalpart" + set tok "." + } + XXXdottedkey-space { + ### obs? + set_tokenType "dotsep" + set tok "." + return 1 + } + dottedkey-space-tail { + ### + set_tokenType "dotsep" + set tok "." + return 1 + } + default { + set_tokenType "untyped_value" + set tok "." + } + } + } + + } + " " { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + if {[tcl::string::length $tokenType]} { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + barekey { + #todo had_slash - emit token or error + #whitespace is a terminator for bare keys + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + comment { + if {$had_slash} { + append tok "\\" + } + append tok $dquotes$c + } + string - dquotedkey - itablequotedkey { + if {$had_slash} { append tok "\\" } + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + append tok $dquotes + incr i -1 + return 1 + } + } + literal - literalpart - squotedkey { + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + if {$dquotes ne ""} { + #end whitespace token + #go back by the number of quotes plus this space char + set backchars [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backchars + return 1 + } else { + append tok $c + } + } else { + append tok $c + } + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + if {$dquotes ne ""} { + set_tokenType "stringpart" + set tok $dquotes + incr i -1 + return 1 + } + set_tokenType "whitespace" + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + if {$had_slash} { + error "tomlish unexpected backslash [tomlish::parse::report_line]" + } + set_tokenType "whitespace" + append tok $c + } + } + } + } + tab { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out (?review) + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + barekey { + #whitespace is a terminator for bare keys + incr i -1 + #set_token_waiting type whitespace value $c complete 1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + squotedkey { + append tok $c + } + dquotedkey - string - comment - whitespace { + #REVIEW + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + append tok $dquotes + incr i -1 + return 1 + } + } + literal - literalpart { + append tok $c + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearraynames { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + if {$slash_active} { + set slash_active 0 + } + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + if {$dquotes ne ""} { + set_tokenType stringpart + set tok $dquotes + incr i -1 + return 1 + } else { + set_tokenType whitespace + append tok $c + } + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "whitespace" + append tok $c + } + } + } + } + bom { + #BOM (Byte Order Mark) - ignored by token consumer + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + _start_squote_sequence { + #assert - tok will be one or two squotes only + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart { + append tok $c + } + default { + set_token_waiting type bom value "\uFEFF" complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "bom" + set tok "\uFEFF" + return 1 + } + } + } + } + default { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + if {$dquotes ne ""} { + set backlen [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backlen + return 1 + } else { + incr i -1 + return 1 + } + } else { + #review + incr i -1 ;#We don't have a full token to add to the token_waiting dict - so leave this char for next run. + return 1 + } + } + barekey { + if {[tomlish::utils::is_barekey $c]} { + append tok $c + } else { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" + } + } + starttablename - starttablearrayname { + incr i -1 + #allow statemachine to set context for subsequent chars + return 1 + } + stringpart { + append tok $dquotes$c + } + default { + #e.g comment/string/literal/literalpart/untyped_value/starttablename/starttablearrayname/tablename/tablearrayname + append tok $c + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + table-space - itable-space { + #if no currently active token - assume another key value pair + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + XXXcurly-syntax { + puts stderr "curly-syntax - review" + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + multistring-space { + set_tokenType "stringpart" + if {$had_slash} { + #assert - we don't get had_slash and dquotes at same time + set tok \\$c + } else { + set tok $dquotes$c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + tablename-state { + set_tokenType "tablename" + set tok $c + } + tablearrayname-state { + set_tokenType "tablearrayname" + set tok $c + } + dottedkey-space { + set_tokenType barekey + set tok $c + } + default { + #todo - something like ansistring VIEW to show control chars? + set cshow [string map [list \t tab \v vt] $c] + tomlish::log::debug "- tokloop char '$cshow' setting to untyped_value while state:$state [tomlish::parse::report_line]" + set_tokenType "untyped_value" + set tok $c + } + } + } + } + } + + } + + #run out of characters (eof) + if {[tcl::string::length $tokenType]} { + #check for invalid ending tokens + #if {$state eq "err-state"} { + # error "Reached end of data whilst tokenType = '$tokenType'. INVALID" + #} + switch -exact -- $tokenType { + startquotesequence { + set toklen [tcl::string::length $tok] + if {$toklen == 1} { + #invalid + #eof with open string + error "tomlish eof reached without closing quote for string. [tomlish::parse::report_line]" + } elseif {$toklen == 2} { + #valid + #we ended in a double quote, not actually a startquoteseqence - effectively an empty string + switch_tokenType "startquote" + incr i -1 + #set_token_waiting type string value "" complete 1 + return 1 + } + } + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open literal + error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" + } + 2 { + #review + set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] + set_tokenType "literal" + set tok "" + return 1 + } + } + } + newline { + #The only newline token that has still not been returned should have a tok value of "cr" + puts "tomlish eof reached - with incomplete newline token '$tok'" + if {$tok eq "cr"} { + #we convert lone cr to it's own "cr" token elsewhere in the document to allow statemachine to handle it. + #(which it should generally do by not handling it ie raising an error - or emitting an ERROR list in the tomlish) + #if trailing char is a lone cr - we should encode it the same way as elsewhere that is outside of values + # ie as it's own token. + switch_tokenType "cr" + return 1 + } else { + #should be unreachable + error "tomlish eof reached - with invalid newline token. value: $tok" + } + } + } + set_token_waiting type eof value eof complete 1 startindex $i ;#review + return 1 + } else { + ::tomlish::log::debug "- No current tokenType, ran out of characters, setting tokenType to 'eof' [tomlish::parse::report_line]" + set tokenType "eof" + set tok "eof" + } + return 0 + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::parse ---}] +} + +namespace eval tomlish::dict { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} + } + proc is_tomlish_typeval2 {d} { + upvar ::tomlish::tags tags + expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} + } + proc last_tomltype_posn {d} { + set last_simple -1 + set dictposn [expr {[dict size $d] -1}] + foreach k [lreverse [dict keys $d]] { + set dval [dict get $d $k] + if {[is_tomlish_typeval $dval]} { + set last_simple $dictposn + break + } + incr dictposn -1 + } + return $last_simple + } + + + #review + proc name_from_tablestack {tablestack} { + set name "" + foreach tinfo [lrange $tablestack 1 end] { + lassign $tinfo type namepart + switch -- $type { + T { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + I { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + default { + #end at first break in the leading sequence of T & I tablenames + break + } + } + } + return $name + } + +} + +tcl::namespace::eval tomlish::app { + variable applist [list encoder decoder test] + + #*** !doctools + #[subsection {Namespace tomlish::app}] + #[para] + #[list_begin definitions] + + proc decoder {args} { + #*** !doctools + #[call app::[fun decoder] [arg args]] + #[para] read toml on stdin until EOF + #[para] on error - returns non-zero exit code and writes error on stderr + #[para] on success - returns zero exit code and writes JSON encoding of the data on stdout + #[para] This decoder is intended to be compatible with toml-test + + set opts [dict merge [dict create] $args] + #fconfigure stdin -encoding utf-8 + fconfigure stdin -translation binary + #Just slurp it all - presumably we are not handling massive amounts of data on stdin. + # - even if the input is large, we probably don't gain much (aside from possible memory savings?) by attempting to process input as it arrives. + if {[catch { + set toml [read stdin] + }]} { + exit 2 ;#read error + } + try { + set j [::tomlish::toml_to_json $toml] + } on error {em} { + puts stderr "decoding failed: '$em'" + exit 1 + } + puts -nonewline stdout $j + exit 0 + } + + proc encoder {args} { + #*** !doctools + #[call app::[fun encoder] [arg args]] + #[para] read JSON on stdin until EOF + #[para] return non-zero exitcode if JSON data cannot be converted to a valid TOML representation + #[para] return zero exitcode and TOML data on stdout if JSON data can be converted. + #[para] This encoder is intended to be compatible with toml-test + + set opts [dict merge [dict create] $args] + fconfigure stdin -translation binary + if {[catch { + set json [read stdin] + }]} { + exit 2 ;#read error + } + try { + set toml [::tomlish::json_to_toml $json] + } on error {em} { + puts stderr "encoding failed: '$em'" + exit 1 + } + puts -nonewline stdout $toml + exit 0 + } + + proc test {args} { + set opts [dict merge [dict create] $args] + + package require test::tomlish + if {[dict exists $opts -suite]} { + test::tomlish::suite [dict get $opts -suite] + } + test::tomlish::run + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::app ---}] +} + +proc ::tomlish::appnames {} { + set applist [list] + foreach cmd [info commands ::tomlish::app::*] { + lappend applist [namespace tail $cmd] + } + return $applist +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace tomlish::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 tomlish::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +if {$argc > 0} { + puts stderr "argc: $argc args: $argv" + + if {($argc == 1)} { + if {[tcl::string::tolower $argv] in {help -help h -h}} { + puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + exit 0 + } else { + puts stderr "Argument '$argv' not understood. Try -help" + exit 1 + } + } + set opts [dict create] + set opts [dict merge $opts $argv] + + set opts_understood [list -app ] + if {"-app" in [dict keys $opts]} { + #Don't vet the remaining opts - as they are interpreted by each app + } else { + foreach key [dict keys $opts] { + if {$key ni $opts_understood} { + puts stderr "Option '$key' not understood" + exit 1 + } + } + } + if {[dict exists $opts -app]} { + set app [dict get $opts -app] + if {$app ni [tomlish::appnames]} { + puts stderr "app '[dict get $opts -app]' not found" + exit 1 + } + tomlish::app::$app {*}$opts + } +} + +## Ready +package provide tomlish [namespace eval tomlish { + variable pkg tomlish + variable version + set version 1.1.3 +}] +return + +#*** !doctools +#[manpage_end] + 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 6776eb79..775335c3 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 @@ -2,12 +2,15 @@ # # punkboot - make any tclkits and modules in /src folders and place them and associated data files/scripts in the parent folder of src. #e.g in 'bin' and 'modules' folders at same level as 'src' folder. +if {[info exists ::env(NO_COLOR)]} { + namespace eval ::punk::console {variable colour_disabled 1} +} set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" puts $hashline -puts " Punk Boot" +puts " Punk Boot" puts $hashline\n -package prefer latest +package prefer latest lassign [split [info tclversion] .] tclmajorv tclminorv global A ;#UI Ansi code array @@ -104,7 +107,7 @@ namespace eval ::punkboot::lib { } } return [join $newparts .] - } + } proc tm_version_required_canonical {versionspec} { #also trim leading zero from any dottedpart? #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. @@ -112,10 +115,10 @@ namespace eval ::punkboot::lib { #also 1b3 == 1b0003 if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version - set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification" + set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification" if {[string first - $versionspec] < 0} { - #no dash - #looks like a minbounded version (ie a single version with no dash) convert to min-max form + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form set from $versionspec if {![::punkboot::lib::tm_version_isvalid $from]} { error "$errmsg '$versionpec'" @@ -127,7 +130,7 @@ namespace eval ::punkboot::lib { error "$errmsg '$versionspec'" } } else { - # min- or min-max + # min- or min-max #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) set parts [split $versionspec -] ;#we expect only 2 parts lassign $parts from to @@ -162,18 +165,18 @@ if {"::try" ni [info commands ::try]} { #------------------------------------------------------------------------------ #Module loading from src/bootsupport or [pwd]/modules if pwd is a 'src' folder #------------------------------------------------------------------------------ -#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files +#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files # - then it will attempt to preference these modules # This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the boot script # and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables set startdir [pwd] #we are focussed on pure-tcl libs/modules in bootsupport for now. -#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc +#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc #REVIEW - punkboot can really speed up with appropriate accelerators and/or external binaries # - we need to support that without binary downloads from repos unless the user explicitly asks for that. # - They may already be available in the vfs (or pointed to package paths) of the running executable. # - todo: some user prompting regarding installs with platform-appropriate package managers -# - todo: some user prompting regarding building accelerators from source. +# - todo: some user prompting regarding building accelerators from source. # ------------------------------------------------------------------------------------- set bootsupport_module_paths [list] @@ -209,7 +212,7 @@ if {[file tail $startdir] eq "src"} { #todo - other src 'module' dirs.. foreach p [list $startdir/modules $startdir/modules_tcl$::tclmajorv $startdir/vendormodules $startdir/vendormodules_tcl$::tclmajorv] { if {[file exists $p]} { - lappend sourcesupport_module_paths $p + lappend sourcesupport_module_paths $p } } # -- -- -- @@ -219,7 +222,7 @@ if {[file tail $startdir] eq "src"} { } } # -- -- -- - + foreach p [list {*}$sourcesupport_module_paths {*}$sourcesupport_library_paths] { if {[file exists $p]} { set sourcesupport_paths_exist 1 @@ -228,7 +231,7 @@ if {[file tail $startdir] eq "src"} { } if {$sourcesupport_paths_exist} { - #launch from auto_path $::auto_path" @@ -281,18 +284,19 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { #package require Thread # - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly. - - + # tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list - #These are strong dependencies + #These are strong dependencies package forget punk::mix - package forget punk::repo - package forget punkcheck + package forget punk::repo + package forget punkcheck package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies package require punk::mix package require punkcheck package require punk::lib + package require punk::args + package require punk::ansi set package_paths_modified 1 @@ -302,11 +306,12 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { set ::punkboot::pkg_requirements_found [list] #we will treat 'package require .' (minbounded) as .- ie explicitly convert to corresponding bounded form -#put some with leading zeros to test normalisation +#put some with leading zeros to test normalisation set ::punkboot::bootsupport_requirements [dict create\ punk::repo [list version "00.01.01-"]\ punk::mix [list version ""]\ punk::ansi [list]\ + punk::args [list]\ overtype [list version "1.6.5-"]\ punkcheck [list]\ fauxlink [list version "0.1.1-"]\ @@ -322,7 +327,7 @@ dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { if {![catch {::punkboot::lib::tm_version_required_canonical $ver} canonical]} { if {$canonical ne $ver} { dict set pkginfo version $canonical ;# plain ver mapped to min-max. min- and min-max and empty left as is - dict set ::punkboot::bootsupport_requirements $pkg $pkginfo + dict set ::punkboot::bootsupport_requirements $pkg $pkginfo } } else { puts stderr "punkboot::bootsupport_requirements - package $pkg has invalid version specification '$ver'" @@ -331,9 +336,9 @@ dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { } else { #make sure each has a blank version entry if nothing was there. dict set pkginfo version "" - dict set ::punkboot::bootsupport_requirements $pkg $pkginfo + dict set ::punkboot::bootsupport_requirements $pkg $pkginfo } -} +} #Assert - our bootsupport_requirement version numbers should now be either empty or of the form min- or min-max #dict for {k v} $::punkboot::bootsupport_requirements { # puts "- $k $v" @@ -356,7 +361,7 @@ set ::punkboot::bootsupport_recommended [dict create\ # create an interp in which we hijack package command # This allows us to auto-gather some dependencies (not necessarily all and not necessarily strictly required) # Note: even in a separate interp we could still possibly get side-effects if a package has compiled components - REVIEW -# Hopefully the only side-effect is that a subsequent load of the package will be faster... +# Hopefully the only side-effect is that a subsequent load of the package will be faster... # (punk boot is intended to operate without compiled components - but some could be pulled in by tcl modules if they're found) # (tcllibc is also highly desirable as the performance impact when not available can be dramatic.) # ... but if the binary is loaded with a different path name when we come to actually use it - there could be issues. @@ -378,7 +383,7 @@ proc ::punkboot::check_package_availability {args} { #best effort at auto-determinining packages required (dependencies) based on top-level packages in the list. #Without fully parsing the package-loading Tcl scripts and examining all side-effects (an unlikely capability), # this is not going to be as accurate as the package developer providing a definitive list of which packages are required and which are optional. - # 'optionality' is a contextual concept anyway depending on how the package is intended to be used. + # 'optionality' is a contextual concept anyway depending on how the package is intended to be used. # The package developer may consider a feature optional - but it may not be optional in a particular usecase. set bootsupport_requirements [lindex $args end] @@ -484,7 +489,7 @@ proc ::punkboot::check_package_availability {args} { #should still distinguish: {pkgname {}} -valid vs {pkgname {{}}} due to empty string supplied in call - invalid - but leave for underlying package command to error on set pkgrequest [list $pkgname $requirements_list] if {$pkgrequest ni $::test::pkg_requested} { - lappend ::test::pkg_requested $pkgrequest + lappend ::test::pkg_requested $pkgrequest } # -- -- --- --- --- --- --- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -507,13 +512,13 @@ proc ::punkboot::check_package_availability {args} { } if {[llength $::test::pkg_stack]} { set caller [lindex $::test::pkg_stack end] - set required_by [dict get $pinfo required_by] + set required_by [dict get $pinfo required_by] if {$caller ni $required_by} { lappend required_by $caller } dict set pinfo required_by $required_by } - lappend ::test::pkg_stack $pkgname + lappend ::test::pkg_stack $pkgname #At this point we could short circuit if we've already classified this package/requirements combo as missing/broken from a previous require #review - there is some chance the exact pkg/requirements combo may succeed after an earlier failure if some package adjusted search paths.. @@ -527,23 +532,23 @@ proc ::punkboot::check_package_availability {args} { #use our normalised requirements instead of original args #if {[catch [list ::package_orig {*}$args] result]} {} if {[catch [list ::package_orig require $pkgname {*}$requirements_list] result]} { - dict set pinfo testerror $result + dict set pinfo testerror $result #package missing - or exists - but failing to initialise if {!$::opt_quiet} { set parent_path [lrange $::test::pkg_stack 0 end-1] puts stderr "\x1b\[32m $pkgname versions: $versions error: $result\x1b\[m" set parent_path [join $parent_path " -> "] - puts stderr "pkg requirements: $parent_path" + puts stderr "pkg requirements: $parent_path" puts stderr "error during : '$args'" puts stderr " \x1b\[93m$result\x1b\[m" } #the failed package may still exist - so we could check 'package files' and 'package ifneeded' here too - REVIEW - #to determine the version that we attempted to load, + #to determine the version that we attempted to load, #- we need to look at 'pkg versions' vs -exact / ver / ver-ver (using package vsatisfies) if {![llength $versions]} { #no versions *and* we had an error - missing is our best guess. review. - #'package versions Tcl' never shows any results + #'package versions Tcl' never shows any results #so requests for old versions will show as missing not broken. #This is probably better anyway. if {$pkgrequest ni $::test::pkg_missing} { @@ -572,21 +577,21 @@ proc ::punkboot::check_package_availability {args} { lappend selectable_versions $v } } else { - #we are operating under 'package prefer' = latest + #we are operating under 'package prefer' = latest set selectable_versions $ordered_versions } if {[llength $requirements_list]} { #add one or no entry for each requirement. #pick highest at end - set satisfiers [list] + set satisfiers [list] foreach requirement $requirements_list { foreach ver [lreverse $selectable_versions] { if {[package vsatisfies $ver $requirement]} { lappend satisfiers $ver break - } - } + } + } } if {[llength $satisfiers]} { set satisfiers [lsort -command {::package_orig vcompare} $satisfiers] @@ -622,7 +627,7 @@ proc ::punkboot::check_package_availability {args} { if {![catch {::package_orig files Tcl} ]} { #tcl9 (also some 8.6/8.7) has 'package files' subcommand. #unfortunately, in some cases (e.g md5 when no accelerators available) this can be a huge list (1000+) showing all scanned pkgIndex.tcl files from unrelated packages. - #We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour + #We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour #see: https://core.tcl-lang.org/tcl/tktview/209fd9adce set all_files [::package_orig files $pkgname] #some arbitrary threshold? REVIEW @@ -637,7 +642,7 @@ proc ::punkboot::check_package_availability {args} { dict set pinfo packagefiles {} ;#default #there are all sorts of scripts, so this is not predictably structured #e.g using things like apply - #we will attempt to get a trailing source .. + #we will attempt to get a trailing source .. set parts [split [string trim $ifneeded_script] {;}] set trimparts [list] foreach p $parts { @@ -648,7 +653,7 @@ proc ::punkboot::check_package_availability {args} { if {$last_with_text ne "" && [regexp -- {\S+$} $last_with_text lastword]} { #if it's a file or dir - close enough (?) #e.g tcllibc uses apply and the last entry is actuall a folder used to find the file.. - #we aren't brave enough to try to work out the actual file(s) + #we aren't brave enough to try to work out the actual file(s) if {[file exists $lastword]} { dict set pinfo packagefiles $lastword } @@ -662,10 +667,10 @@ proc ::punkboot::check_package_availability {args} { return [uplevel 1 [list ::package_orig {*}$args]] } } - + set ::test::pkg_stack [list] catch {::package_orig require zzz-non-existant} ;#scan so we get 'package versions' results - dict for {pkg pkgdict} $::test::bootsupport_requirements { + dict for {pkg pkgdict} $::test::bootsupport_requirements { #set nsquals [namespace qualifiers $pkg] #if {$nsquals ne ""} { # catch {::package_orig require ${nsquals}::zzz-non-existant} ;#force scan of every level encountered @@ -690,7 +695,7 @@ proc ::punkboot::check_package_availability {args} { # set ver [package provide $pkg] # if {$ver eq ""} { # #puts stderr "missing pkg: $pkg" - # lappend ::test::pkg_missing $pkg + # lappend ::test::pkg_missing $pkg # } else { # if {[string tolower $pkg] eq "tcl"} { # #ignore @@ -1180,17 +1185,17 @@ if {$::punkboot::command eq "check"} { puts stdout "- tcl::tm::list" foreach fld [tcl::tm::list] { if {[file exists $fld]} { - puts stdout " $fld" + puts stdout " $fld" } else { - puts stdout " $fld (not present)" + puts stdout " $fld (not present)" } } puts stdout "- auto_path" foreach fld $::auto_path { if {[file exists $fld]} { - puts stdout " $fld" + puts stdout " $fld" } else { - puts stdout " $fld (not present)" + puts stdout " $fld (not present)" } } flush stdout @@ -1283,22 +1288,22 @@ if {$::punkboot::command eq "info"} { set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] puts stdout "- vendorlib folders: ([llength $vendorlibfolders])" foreach fld $vendorlibfolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } puts stdout "- vendormodule folders: ([llength $vendormodulefolders])" foreach fld $vendormodulefolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] puts stdout "- source module paths: [llength $source_module_folderlist]" foreach fld $source_module_folderlist { - puts stdout " $fld" + puts stdout " $fld" } set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] lappend projectlibfolders lib puts stdout "- source libary paths: [llength $projectlibfolders]" foreach fld $projectlibfolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { set vc "fossil" @@ -1389,10 +1394,9 @@ if {$::punkboot::command eq "vendorupdate"} { #todo vendor/lib set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] - set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] - lappend vendormodulefolders vendormodules + set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] + #lappend vendormodulefolders vendormodules foreach vf $vendormodulefolders { - if {[file exists $sourcefolder/$vf]} { lassign [split $vf _] _vm tclx if {$tclx ne ""} { set which _$tclx @@ -1481,7 +1485,6 @@ if {$::punkboot::command eq "vendorupdate"} { } else { puts stderr "No config at $vendor_config - nothing configured to update" } - } } } @@ -1508,105 +1511,102 @@ if {$::punkboot::command eq "bootsupport"} { set bootsupport_modules [list] ;#variable populated by include_modules.config file - review set sourcefolder $projectroot/src - set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules_tcl*] - lappend bootmodulefolders modules + set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules modules_tcl*] foreach bm $bootmodulefolders { - if {[file exists $sourcefolder/bootsupport/$bm]} { - lassign [split $bm _] _bm tclx - if {$tclx ne ""} { - set which _$tclx + lassign [split $bm _] _bm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# + if {[file exists $bootsupport_config]} { + set targetroot $projectroot/src/bootsupport/modules$which + source $bootsupport_config ;#populate $bootsupport_modules with project-specific list + if {![llength $bootsupport_modules]} { + puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" } else { - set which "" - } - set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# - if {[file exists $bootsupport_config]} { - set targetroot $projectroot/src/bootsupport/modules$which - source $bootsupport_config ;#populate $bootsupport_modules with project-specific list - if {![llength $bootsupport_modules]} { - puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" - } else { - if {[catch { - #---------- - set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] - $boot_installer set_source_target $projectroot $projectroot/src/bootsupport - set boot_event [$boot_installer start_event {-make_step bootsupport}] - #---------- - } errM]} { - puts stderr "Unable to use punkcheck for bootsupport error: $errM" - set boot_event "" - } + if {[catch { + #---------- + set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] + $boot_installer set_source_target $projectroot $projectroot/src/bootsupport + set boot_event [$boot_installer start_event {-make_step bootsupport}] + #---------- + } errM]} { + puts stderr "Unable to use punkcheck for bootsupport error: $errM" + set boot_event "" + } - foreach {relpath modulematch} $bootsupport_modules { - set modulematch [string trim $modulematch :] - set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]] - set srclocation [file join $projectroot $relpath $module_subpath] - #puts stdout "$relpath $modulematch $module_subpath $srclocation" - if {[string first - $modulematch]} { - set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm] - } else { - set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm] - } - if {![llength $pkgmatches]} { - puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation" - continue - } + foreach {relpath modulematch} $bootsupport_modules { + set modulematch [string trim $modulematch :] + set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $modulematch $module_subpath $srclocation" + if {[string first - $modulematch]} { + set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm] + } else { + set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm] + } + if {![llength $pkgmatches]} { + puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation" + continue + } - set modulematch_is_glob [regexp {[*?\[\]]} $modulematch] - if {!$modulematch_is_glob} { - #if modulematch was specified without globs - only copy latest - #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func - set pkgmatches [lsort -command modfile_sort $pkgmatches] - set latestfile [lindex $pkgmatches end] - #set latestver [lindex [split [file rootname $latestfile] -] 1] - set copy_files $latestfile - } else { - #globs in modulematch - may be different packages matched by glob - copy all versions of matches - #review - set copy_files $pkgmatches - } - foreach cfile $copy_files { - set srcfile [file join $srclocation $cfile] - set tgtfile [file join $targetroot $module_subpath $cfile] - if {$boot_event ne ""} { - #---------- - $boot_event targetset_init INSTALL $tgtfile - $boot_event targetset_addsource $srcfile - #---------- - if {\ - [llength [dict get [$boot_event targetset_source_changes] changed]]\ - || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ - } { - file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists - $boot_event targetset_started - # -- --- --- --- --- --- - puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile" - if {[catch { - file copy -force $srcfile $tgtfile - } errM]} { - $boot_event targetset_end FAILED - } else { - $boot_event targetset_end OK - } - # -- --- --- --- --- --- + set modulematch_is_glob [regexp {[*?\[\]]} $modulematch] + if {!$modulematch_is_glob} { + #if modulematch was specified without globs - only copy latest + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func + set pkgmatches [lsort -command modfile_sort $pkgmatches] + set latestfile [lindex $pkgmatches end] + #set latestver [lindex [split [file rootname $latestfile] -] 1] + set copy_files $latestfile + } else { + #globs in modulematch - may be different packages matched by glob - copy all versions of matches + #review + set copy_files $pkgmatches + } + foreach cfile $copy_files { + set srcfile [file join $srclocation $cfile] + set tgtfile [file join $targetroot $module_subpath $cfile] + if {$boot_event ne ""} { + #---------- + $boot_event targetset_init INSTALL $tgtfile + $boot_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$boot_event targetset_source_changes] changed]]\ + || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ + } { + file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists + $boot_event targetset_started + # -- --- --- --- --- --- + puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $boot_event targetset_end FAILED } else { - puts -nonewline stderr "." - $boot_event targetset_end SKIPPED + $boot_event targetset_end OK } - $boot_event end + # -- --- --- --- --- --- } else { - file copy -force $srcfile $tgtfile + puts -nonewline stderr "." + $boot_event targetset_end SKIPPED } + $boot_event end + } else { + file copy -force $srcfile $tgtfile } } - if {$boot_event ne ""} { - puts \n - $boot_event destroy - $boot_installer destroy - } } - + if {$boot_event ne ""} { + puts \n + $boot_event destroy + $boot_installer destroy + } } + } } } @@ -1699,59 +1699,53 @@ if {$::punkboot::command ni {project modules vfs}} { #install src vendor contents (from version controlled src folder) to base of project (same target folders as our own src/modules etc ie to paths that go on the auto_path and in tcl::tm::list) if {$::punkboot::command in {project modules}} { - set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] - lappend vendorlibfolders vendorlib - foreach lf $vendorlibfolders { - if {[file exists $sourcefolder/$lf]} { - lassign [split $lf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_lib_folder $projectroot/lib$which - file mkdir $projectroot/lib$which - #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g - # */test.txt will only match test.txt exactly one level deep. - # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. - # **/test.txt will match at any level below the root (but not in the root) - set antipaths [list\ - README.md\ - ] - puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] - } - } - if {![llength $vendorlibfolders]} { - puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." - } - - set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] - lappend vendormodulefolders vendormodules - + set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] foreach vf $vendormodulefolders { - if {[file exists $sourcefolder/$vf]} { - lassign [split $vf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_module_folder $projectroot/modules$which - file mkdir $target_module_folder - - #install .tm *and other files* - puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] + lassign [split $vf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" } + set target_module_folder $projectroot/modules$which + file mkdir $target_module_folder + + #install .tm *and other files* + puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $vendormodulefolders]} { puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found." } + set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib vendorlib_tcl*] + foreach lf $vendorlibfolders { + lassign [split $lf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_lib_folder $projectroot/lib$which + file mkdir $projectroot/lib$which + #exclude README.md from source folder - but only the root one + #-antiglob_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) + set antipaths [list\ + README.md\ + ] + puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } + if {![llength $vendorlibfolders]} { + puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." + } + + ######################################################## #templates #e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync @@ -1760,10 +1754,10 @@ if {$::punkboot::command in {project modules}} { set old_layout_update_list [list\ [list project $sourcefolder/modules/punk/mix/templates]\ [list basic $sourcefolder/mixtemplates]\ - ] + ] set layout_bases [list\ $sourcefolder/project_layouts/custom/_project\ - ] + ] foreach layoutbase $layout_bases { if {![file exists $layoutbase]} { @@ -1823,27 +1817,25 @@ if {$::punkboot::command in {project modules}} { set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] lappend projectlibfolders lib foreach lf $projectlibfolders { - if {[file exists $sourcefolder/$lf]} { - lassign [split $lf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_lib_folder $projectroot/lib$which - file mkdir $projectroot/lib$which - #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g - # */test.txt will only match test.txt exactly one level deep. - # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. - # **/test.txt will match at any level below the root (but not in the root) - set antipaths [list\ - README.md\ - ] - puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] - } + lassign [split $lf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_lib_folder $projectroot/lib$which + file mkdir $projectroot/lib$which + #exclude README.md from source folder - but only the root one + #-antiglob_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) + set antipaths [list\ + README.md\ + ] + puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $projectlibfolders]} { puts stderr "PROJECTLIB: No src/lib or src/lib_tcl* folder found." @@ -2355,7 +2347,7 @@ foreach vfstail $vfs_tails { } else { lappend runtimes $matchrt } - } + } } #assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm index a45eaeaf..7884214c 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm @@ -1,514 +1,514 @@ - - -#JMN 2021 - Public Domain -#cooperative command renaming -# -# REVIEW 2024 - code was originally for specific use in packageTrace -# - code should be reviewed for more generic utility. -# - API is obscure and undocumented. -# - unclear if intention was only for builtins -# - consider use of newer 'info cmdtype' - (but need also support for safe interps) -# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. -# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename -#changes: -#2024 -# - mungecommand to support namespaced commands -# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ -#2021-09-18 -# - initial version -# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command -# - They need to be able to load and unload in any order. -# - -#strive for no other package dependencies here. - - -namespace eval commandstack { - variable all_stacks - variable debug - set debug 0 - variable known_renamers [list ::packagetrace ::packageSuppress] - if {![info exists all_stacks]} { - #don't wipe it - set all_stacks [dict create] - } -} - -namespace eval commandstack::util { - #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. - #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace - #A magic comment was chosen as the identifying method. - #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. - - #return unspecified if the command is a proc with a body but no magic comment ID - #return unknown if the command doesn't have a proc body to analyze - #otherwise return the package name identified in the magic comment - proc get_IMPLEMENTOR {command} { - #assert - command has already been resolved to a namespace ie fully qualified - if {[llength [info procs $command]]} { - #look for *IMPLEMENTOR_*! - set prefix IMPLEMENTOR_ - set suffix "!" - set body [uplevel 1 [list info body $command]] - if {[string match "*$prefix*$suffix*" $body]} { - set prefixposn [string first "$prefix" $body] - set pkgposn [expr {$prefixposn + [string length $prefix]}] - #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] - set suffixposn [string first $suffix $body $pkgposn] - return [string range $body $pkgposn $suffixposn-1] - } else { - return unspecified - } - } else { - if {[info commands tcl::info::cmdtype] ne ""} { - #tcl9 and maybe some tcl 8.7s ? - switch -- [tcl::info::cmdtype $command] { - native { - return builtin - } - default { - return undetermined - } - } - } else { - return undetermined - } - } - } -} -namespace eval commandstack::renamed_commands {} -namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place - -namespace eval commandstack { - namespace export {[a-z]*} - proc help {} { - return { - - } - } - - proc debug {{on_off {}}} { - variable debug - if {$on_off eq ""} { - return $debug - } else { - if {[string is boolean -strict $debug]} { - set debug [expr {$on_off && 1}] - return $debug - } - } - } - - proc get_stack {command} { - variable all_stacks - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - return [dict get $all_stacks $command] - } else { - return [list] - } - } - - #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. - #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? - #e.g if renaming builtin 'package' - this command is generally called 'a lot' - proc get_next_command {command renamer tokenid} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] - if {$posn > -1} { - set record [lindex $stack $posn] - return [dict get $record implementation] - } else { - error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" - } - } else { - return $command - } - } - proc basecall {command args} { - variable all_stacks - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {[llength $stack]} { - set rec1 [lindex $stack 0] - tailcall [dict get $rec1 implementation] {*}$args - } else { - tailcall $command {*}$args - } - } else { - tailcall $command {*}$args - } - } - - - #review. - # defaults to calling namespace - but can be arbitrary string - proc rename_command {args} { - #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames - # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack - # - if {[lindex $args 0] eq "-renamer"} { - set renamer [lindex $args 1] - set arglist [lrange $args 2 end] - } else { - set renamer "" - set arglist $args - } - if {[llength $arglist] != 3} { - error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" - } - lassign $arglist command procargs procbody - - set command [uplevel 1 [list namespace which $command]] - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - variable all_stacks - variable known_renamers - variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. - if {$renamer eq ""} { - set renamer [uplevel 1 [list namespace current]] - } - if {$renamer ni $known_renamers} { - lappend known_renamers $renamer - dict set renamer_command_tokens [list $renamer $command] 0 - } - - #TODO - reduce emissions to stderr - flag for debug? - - #e.g packageTrace and packageSuppress packages use this convention. - set nextinfo [uplevel 1 [list\ - apply {{command renamer procbody} { - #todo - munge dash so we can make names in renamed_commands separable - # {- _dash_} ? - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] - set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. - set do_rename 0 - if {[llength [info procs $command]] || [llength [info commands $next_target]]} { - #$command is not the standard builtin - something has replaced it, could be ourself. - set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] - set munged_next_implementor [string map {:: _ns_} $next_implementor] - #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. - if {[dict exists $::commandstack::all_stacks $command]} { - set comstacks [dict get $::commandstack::all_stacks $command] - } else { - set comstacks [list] - } - set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') - if {[llength $this_renamer_previous_entries]} { - if {$next_implementor eq $renamer} { - #previous renamer was us. Rather than assume our job is done.. compare the implementations - #don't rename if immediate predecessor is same code. - #set topstack [lindex $comstacks end] - #set next_impl [dict get $topstack implementation] - set current_body [info body $command] - lassign [commandstack::lib::split_body $current_body] _ current_code - set current_code [string trim $current_code] - set new_code [string trim $procbody] - if {$current_code eq $new_code} { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." - puts stderr [::commandstack::show_stack $command] - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." - puts stdout "----------" - puts stdout "$current_code" - puts stdout "----------" - puts stdout "$new_code" - puts stdout "----------" - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" - puts stderr - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } elseif {$next_implementor in $::commandstack::known_renamers} { - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {builtin}} { - #native/builtin could still have been renamed - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {unspecified undetermined}} { - #could be a standard tcl proc, or from application or package - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } else { - puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - #_originalcommand_ - #assume builtin/original - set next_implementor original - #rename $command $next_target - set do_rename 1 - } - #There are of course other ways in which $command may have been renamed - but we can't detect. - set token [list $command $renamer $tokenid] - return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] - } } $command $renamer $procbody] - ] - - - variable debug - if $debug { - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" - } else { - #assume this is the original - puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" - } - } - - #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) - #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) - set new_record [dict create\ - token [dict get $nextinfo token]\ - renamer $renamer\ - next_implementor [dict get $nextinfo next_implementor]\ - next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ - implementation [dict get $nextinfo next_target]\ - ] - if {![dict get $nextinfo do_rename]} { - #review - puts stderr "no rename performed" - return [dict create implementation ""] - } - catch {rename ::commandstack::temp::testproc ""} - set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { - #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) - set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. - set COMMANDSTACKNEXT [%next_getter%] - ## - }] - set final_procbody "$nextinit$procbody" - #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command - #(e.g due to invalid argument specifiers) - proc ::commandstack::temp::testproc $procargs $final_procbody - uplevel 1 [list rename $command [dict get $nextinfo next_target]] - uplevel 1 [list rename ::commandstack::temp::testproc $command] - dict lappend all_stacks $command $new_record - - - return $new_record - } - - #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer - #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost - #todo - removal of all entries pertaining to a particular renamer - #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? - - #remove by token, or by commandname if called from same context as original rename_command - #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. - #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. - #similarly a nonexistant token or renamer will not remove anything and will just return the current stack - proc remove_rename {token_or_command} { - if {[llength $token_or_command] == 3} { - #is token - lassign $token_or_command command renamer tokenid - } elseif {[llength $token_or_command] == 2} { - #command and renamer only supplied - lassign $token_or_command command renamer - set tokenid "" - } elseif {[llength $token_or_command] == 1} { - #is command name only - set command $token_or_command - set renamer [uplevel 1 [list namespace current]] - set tokenid "" - } - set command [uplevel 1 [list namespace which $command]] - variable all_stacks - variable known_renamers - if {$renamer ni $known_renamers} { - error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" - } - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {$tokenid ne ""} { - #token_or_command is a token as returned within the rename_command result dictionary - #search first dict value - set doomed_posn [lsearch -index 1 $stack $token_or_command] - } else { - #search second dict value - set matches [lsearch -all -index 3 $stack $renamer] - set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer - } - if {$doomed_posn ne "" && $doomed_posn > -1} { - set doomed_record [lindex $stack $doomed_posn] - if {[llength $stack] == ($doomed_posn + 1)} { - #last on stack - put the implemenation from the doomed_record back as the actual command - uplevel #0 [list rename $command ""] - uplevel #0 [list rename [dict get $doomed_record implementation] $command] - } elseif {[llength $stack] > ($doomed_posn + 1)} { - #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed - set rewrite_posn [expr {$doomed_posn + 1}] - set rewrite_record [lindex $stack $rewrite_posn] - - if {[dict get $rewrite_record next_implementor] ne $renamer} { - puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" - } else { - uplevel #0 [list rename [dict get $rewrite_record implementation] ""] - } - dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] - #don't update next_getter - it always refers to self - dict set rewrite_record implementation [dict get $doomed_record implementation] - lset stack $rewrite_posn $rewrite_record - dict set all_stacks $command $stack - } - set stack [lreplace $stack $doomed_posn $doomed_posn] - dict set all_stacks $command $stack - - } - return $stack - } - return [list] - } - - proc show_stack {{commandname_glob *}} { - variable all_stacks - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } - if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { - #punk pipeline also needed for patterns - return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] - } else { - set result "" - set matchedkeys [dict keys $all_stacks $commandname_glob] - #don't try to calculate widest on empty list - if {[llength $matchedkeys]} { - set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] - set indent [string repeat " " [expr {$widest + 3}]] - set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide - set padkey [string repeat " " 20] - foreach k $matchedkeys { - append result "$k = " - set i 0 - foreach stackmember [dict get $all_stacks $k] { - if {$i > 0} { - append result "\n$indent" - } - append result [string range "$i " 0 4] " = " - set j 0 - dict for {k v} $stackmember { - if {$j > 0} { - append result "\n$indent2" - } - set displaykey [string range "$k$padkey" 0 20] - append result "$displaykey = $v" - incr j - } - incr i - } - append result \n - } - } - return $result - } - } - - #review - #document when this is to be called. Wiping stacks without undoing renames seems odd. - proc Delete_stack {command} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - dict unset all_stacks $command - return 1 - } else { - return 1 - } - } - - #can be used to temporarily put a stack aside - should manually rename back when done. - #review - document how/when to use. example? intention? - proc Rename_stack {oldname newname} { - variable all_stacks - if {[dict exists $all_stacks $oldname]} { - if {[dict exists $all_stacks $newname]} { - error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" - } else { - #set stackval [dict get $all_stacks $oldname] - #dict unset all_stacks $oldname - #dict set all_stacks $newname $stackval - dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] - } - } - } -} - - - - - - - - -namespace eval commandstack::lib { - proc splitx {str {regexp {[\t \r\n]+}}} { - #snarfed from tcllib textutil::splitx to avoid the dependency - # Bugfix 476988 - if {[string length $str] == 0} { - return {} - } - if {[string length $regexp] == 0} { - return [::split $str ""] - } - if {[regexp $regexp {}]} { - return -code error "splitting on regexp \"$regexp\" would cause infinite loop" - } - - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - foreach {subStart subEnd} $submatch break - foreach {matchStart matchEnd} $match break - incr matchStart -1 - incr matchEnd - lappend list [string range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [string range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [string range $str $start end] - return $list - } - proc split_body {procbody} { - set marker "##" - set header "" - set code "" - set found_marker 0 - foreach ln [split $procbody \n] { - if {!$found_marker} { - if {[string trim $ln] eq $marker} { - set found_marker 1 - } else { - append header $ln \n - } - } else { - append code $ln \n - } - } - if {$found_marker} { - return [list $header $code] - } else { - return [list "" $procbody] - } - } -} - -package provide commandstack [namespace eval commandstack { - set version 0.3 -}] - - + + +#JMN 2021 - Public Domain +#cooperative command renaming +# +# REVIEW 2024 - code was originally for specific use in packageTrace +# - code should be reviewed for more generic utility. +# - API is obscure and undocumented. +# - unclear if intention was only for builtins +# - consider use of newer 'info cmdtype' - (but need also support for safe interps) +# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. +# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename +#changes: +#2024 +# - mungecommand to support namespaced commands +# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ +#2021-09-18 +# - initial version +# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command +# - They need to be able to load and unload in any order. +# + +#strive for no other package dependencies here. + + +namespace eval commandstack { + variable all_stacks + variable debug + set debug 0 + variable known_renamers [list ::packagetrace ::packageSuppress] + if {![info exists all_stacks]} { + #don't wipe it + set all_stacks [dict create] + } +} + +namespace eval commandstack::util { + #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. + #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace + #A magic comment was chosen as the identifying method. + #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. + + #return unspecified if the command is a proc with a body but no magic comment ID + #return unknown if the command doesn't have a proc body to analyze + #otherwise return the package name identified in the magic comment + proc get_IMPLEMENTOR {command} { + #assert - command has already been resolved to a namespace ie fully qualified + if {[llength [info procs $command]]} { + #look for *IMPLEMENTOR_*! + set prefix IMPLEMENTOR_ + set suffix "!" + set body [uplevel 1 [list info body $command]] + if {[string match "*$prefix*$suffix*" $body]} { + set prefixposn [string first "$prefix" $body] + set pkgposn [expr {$prefixposn + [string length $prefix]}] + #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] + set suffixposn [string first $suffix $body $pkgposn] + return [string range $body $pkgposn $suffixposn-1] + } else { + return unspecified + } + } else { + if {[info commands tcl::info::cmdtype] ne ""} { + #tcl9 and maybe some tcl 8.7s ? + switch -- [tcl::info::cmdtype $command] { + native { + return builtin + } + default { + return undetermined + } + } + } else { + return undetermined + } + } + } +} +namespace eval commandstack::renamed_commands {} +namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place + +namespace eval commandstack { + namespace export {[a-z]*} + proc help {} { + return { + + } + } + + proc debug {{on_off {}}} { + variable debug + if {$on_off eq ""} { + return $debug + } else { + if {[string is boolean -strict $debug]} { + set debug [expr {$on_off && 1}] + return $debug + } + } + } + + proc get_stack {command} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + return [dict get $all_stacks $command] + } else { + return [list] + } + } + + #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. + #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? + #e.g if renaming builtin 'package' - this command is generally called 'a lot' + proc get_next_command {command renamer tokenid} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] + if {$posn > -1} { + set record [lindex $stack $posn] + return [dict get $record implementation] + } else { + error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" + } + } else { + return $command + } + } + proc basecall {command args} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {[llength $stack]} { + set rec1 [lindex $stack 0] + tailcall [dict get $rec1 implementation] {*}$args + } else { + tailcall $command {*}$args + } + } else { + tailcall $command {*}$args + } + } + + + #review. + # defaults to calling namespace - but can be arbitrary string + proc rename_command {args} { + #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames + # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack + # + if {[lindex $args 0] eq "-renamer"} { + set renamer [lindex $args 1] + set arglist [lrange $args 2 end] + } else { + set renamer "" + set arglist $args + } + if {[llength $arglist] != 3} { + error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" + } + lassign $arglist command procargs procbody + + set command [uplevel 1 [list namespace which $command]] + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + variable all_stacks + variable known_renamers + variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. + if {$renamer eq ""} { + set renamer [uplevel 1 [list namespace current]] + } + if {$renamer ni $known_renamers} { + lappend known_renamers $renamer + dict set renamer_command_tokens [list $renamer $command] 0 + } + + #TODO - reduce emissions to stderr - flag for debug? + + #e.g packageTrace and packageSuppress packages use this convention. + set nextinfo [uplevel 1 [list\ + apply {{command renamer procbody} { + #todo - munge dash so we can make names in renamed_commands separable + # {- _dash_} ? + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] + set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. + set do_rename 0 + if {[llength [info procs $command]] || [llength [info commands $next_target]]} { + #$command is not the standard builtin - something has replaced it, could be ourself. + set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] + set munged_next_implementor [string map {:: _ns_} $next_implementor] + #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. + if {[dict exists $::commandstack::all_stacks $command]} { + set comstacks [dict get $::commandstack::all_stacks $command] + } else { + set comstacks [list] + } + set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') + if {[llength $this_renamer_previous_entries]} { + if {$next_implementor eq $renamer} { + #previous renamer was us. Rather than assume our job is done.. compare the implementations + #don't rename if immediate predecessor is same code. + #set topstack [lindex $comstacks end] + #set next_impl [dict get $topstack implementation] + set current_body [info body $command] + lassign [commandstack::lib::split_body $current_body] _ current_code + set current_code [string trim $current_code] + set new_code [string trim $procbody] + if {$current_code eq $new_code} { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [::commandstack::show_stack $command] + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." + puts stdout "----------" + puts stdout "$current_code" + puts stdout "----------" + puts stdout "$new_code" + puts stdout "----------" + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" + puts stderr + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } elseif {$next_implementor in $::commandstack::known_renamers} { + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {builtin}} { + #native/builtin could still have been renamed + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {unspecified undetermined}} { + #could be a standard tcl proc, or from application or package + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } else { + puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + #_originalcommand_ + #assume builtin/original + set next_implementor original + #rename $command $next_target + set do_rename 1 + } + #There are of course other ways in which $command may have been renamed - but we can't detect. + set token [list $command $renamer $tokenid] + return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] + } } $command $renamer $procbody] + ] + + + variable debug + if {$debug} { + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" + } else { + #assume this is the original + puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" + } + } + + #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) + #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) + set new_record [dict create\ + token [dict get $nextinfo token]\ + renamer $renamer\ + next_implementor [dict get $nextinfo next_implementor]\ + next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ + implementation [dict get $nextinfo next_target]\ + ] + if {![dict get $nextinfo do_rename]} { + #review + puts stderr "no rename performed" + return [dict create implementation ""] + } + catch {rename ::commandstack::temp::testproc ""} + set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { + #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) + set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. + set COMMANDSTACKNEXT [%next_getter%] + ## + }] + set final_procbody "$nextinit$procbody" + #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command + #(e.g due to invalid argument specifiers) + proc ::commandstack::temp::testproc $procargs $final_procbody + uplevel 1 [list rename $command [dict get $nextinfo next_target]] + uplevel 1 [list rename ::commandstack::temp::testproc $command] + dict lappend all_stacks $command $new_record + + + return $new_record + } + + #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer + #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost + #todo - removal of all entries pertaining to a particular renamer + #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? + + #remove by token, or by commandname if called from same context as original rename_command + #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. + #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. + #similarly a nonexistant token or renamer will not remove anything and will just return the current stack + proc remove_rename {token_or_command} { + if {[llength $token_or_command] == 3} { + #is token + lassign $token_or_command command renamer tokenid + } elseif {[llength $token_or_command] == 2} { + #command and renamer only supplied + lassign $token_or_command command renamer + set tokenid "" + } elseif {[llength $token_or_command] == 1} { + #is command name only + set command $token_or_command + set renamer [uplevel 1 [list namespace current]] + set tokenid "" + } + set command [uplevel 1 [list namespace which $command]] + variable all_stacks + variable known_renamers + if {$renamer ni $known_renamers} { + error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" + } + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {$tokenid ne ""} { + #token_or_command is a token as returned within the rename_command result dictionary + #search first dict value + set doomed_posn [lsearch -index 1 $stack $token_or_command] + } else { + #search second dict value + set matches [lsearch -all -index 3 $stack $renamer] + set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer + } + if {$doomed_posn ne "" && $doomed_posn > -1} { + set doomed_record [lindex $stack $doomed_posn] + if {[llength $stack] == ($doomed_posn + 1)} { + #last on stack - put the implemenation from the doomed_record back as the actual command + uplevel #0 [list rename $command ""] + uplevel #0 [list rename [dict get $doomed_record implementation] $command] + } elseif {[llength $stack] > ($doomed_posn + 1)} { + #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed + set rewrite_posn [expr {$doomed_posn + 1}] + set rewrite_record [lindex $stack $rewrite_posn] + + if {[dict get $rewrite_record next_implementor] ne $renamer} { + puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" + } else { + uplevel #0 [list rename [dict get $rewrite_record implementation] ""] + } + dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] + #don't update next_getter - it always refers to self + dict set rewrite_record implementation [dict get $doomed_record implementation] + lset stack $rewrite_posn $rewrite_record + dict set all_stacks $command $stack + } + set stack [lreplace $stack $doomed_posn $doomed_posn] + dict set all_stacks $command $stack + + } + return $stack + } + return [list] + } + + proc show_stack {{commandname_glob *}} { + variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } + if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { + #punk pipeline also needed for patterns + return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] + } else { + set result "" + set matchedkeys [dict keys $all_stacks $commandname_glob] + #don't try to calculate widest on empty list + if {[llength $matchedkeys]} { + set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] + set indent [string repeat " " [expr {$widest + 3}]] + set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide + set padkey [string repeat " " 20] + foreach k $matchedkeys { + append result "$k = " + set i 0 + foreach stackmember [dict get $all_stacks $k] { + if {$i > 0} { + append result "\n$indent" + } + append result [string range "$i " 0 4] " = " + set j 0 + dict for {k v} $stackmember { + if {$j > 0} { + append result "\n$indent2" + } + set displaykey [string range "$k$padkey" 0 20] + append result "$displaykey = $v" + incr j + } + incr i + } + append result \n + } + } + return $result + } + } + + #review + #document when this is to be called. Wiping stacks without undoing renames seems odd. + proc Delete_stack {command} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + dict unset all_stacks $command + return 1 + } else { + return 1 + } + } + + #can be used to temporarily put a stack aside - should manually rename back when done. + #review - document how/when to use. example? intention? + proc Rename_stack {oldname newname} { + variable all_stacks + if {[dict exists $all_stacks $oldname]} { + if {[dict exists $all_stacks $newname]} { + error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" + } else { + #set stackval [dict get $all_stacks $oldname] + #dict unset all_stacks $oldname + #dict set all_stacks $newname $stackval + dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] + } + } + } +} + + + + + + + + +namespace eval commandstack::lib { + proc splitx {str {regexp {[\t \r\n]+}}} { + #snarfed from tcllib textutil::splitx to avoid the dependency + # Bugfix 476988 + if {[string length $str] == 0} { + return {} + } + if {[string length $regexp] == 0} { + return [::split $str ""] + } + if {[regexp $regexp {}]} { + return -code error "splitting on regexp \"$regexp\" would cause infinite loop" + } + + set list {} + set start 0 + while {[regexp -start $start -indices -- $regexp $str match submatch]} { + foreach {subStart subEnd} $submatch break + foreach {matchStart matchEnd} $match break + incr matchStart -1 + incr matchEnd + lappend list [string range $str $start $matchStart] + if {$subStart >= $start} { + lappend list [string range $str $subStart $subEnd] + } + set start $matchEnd + } + lappend list [string range $str $start end] + return $list + } + proc split_body {procbody} { + set marker "##" + set header "" + set code "" + set found_marker 0 + foreach ln [split $procbody \n] { + if {!$found_marker} { + if {[string trim $ln] eq $marker} { + set found_marker 1 + } else { + append header $ln \n + } + } else { + append code $ln \n + } + } + if {$found_marker} { + return [list $header $code] + } else { + return [list "" $procbody] + } + } +} + +package provide commandstack [namespace eval commandstack { + set version 0.3 +}] + + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm index 5d63ffef..970e47da 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm @@ -20,7 +20,7 @@ #[manpage_begin fauxlink_module_fauxlink 0 0.1.1] #[copyright "2024"] #[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] -#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] +#[moddesc {.fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] #[require fauxlink] #[keywords symlink faux fake shortcut toml] #[description] @@ -29,18 +29,19 @@ #[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as #[para] archiving and packaging systems. #[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. -#[para] format of name #.fxlnk +#[para] format of name #.fauxlink #[para] where can be empty - then the effective nominal name is the tail of the +#[para] The file extension must be .fauxlink or .fxlnk #[para] The + symbol substitutes for forward-slashes. #[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) #[para] We deliberately treat higher % sequences literally. #[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls. #[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 #[para] e.g a link to a file file#A.txt in parent dir could be: -#[para] file%23A.txt#..+file%23A.txt.fxlnk -#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk +#[para] file%23A.txt#..+file%23A.txt.fauxlink +#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fauxlink #[para] The can be unrelated to the actual target -#[para] e.g datafile.dat#..+file%23A.txt.fxlnk +#[para] e.g datafile.dat#..+file%23A.txt.fauxlink #[para] This system has no filesystem support - and must be completely application driven. #[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. #[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined @@ -63,9 +64,9 @@ #https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded # ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. #Using fauxlink - a link would be: -# "my-program-files#++server+c+Program%20Files.fxlnk" +# "my-program-files#++server+c+Program%20Files.fauxlink" #If we needed the old-style literal %20 it would become -# "my-program-files#++server+c+Program%2520Files.fxlnk" +# "my-program-files#++server+c+Program%2520Files.fauxlink" # # The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) # e.g @@ -296,12 +297,12 @@ namespace eval fauxlink { set is_fauxlink 0 #we'll process anyway - but return the result wrapped #This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent - #(e.g blindly processing all files in a folder that is normally only .fxlnk files - but then something added that happens + #(e.g blindly processing all files in a folder that is normally only .fauxlink files - but then something added that happens # to have # characters in it) #It also means if someone really wants to use the fauxlink semantics on a different file type # - they can - but just have to access the results differently and take that (minor) risk. #error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" - set err_extra "\nnonstandard extension '$extension_name' for fauxlink. Check that the call to fauxlink::resolve was deliberate" + set err_extra "\nnonstandard extension '$extension_name' for fauxlink. (expected .fxlnk or .fauxlink) Check that the call to fauxlink::resolve was deliberate" } else { set is_fauxlink 1 set err_extra "" @@ -318,7 +319,7 @@ namespace eval fauxlink { #if there are 4 parts - the 3rd part is a tagset where each tag begins with @ #and each subsequent part is a comment. Empty comments are stripped from the comments list #A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @ - #e.g name.txt#path#@tag1@tag2#test###.fxlnk + #e.g name.txt#path#@tag1@tag2#test###.fauxlink #has a name, a target, 2 tags and one comment #check namespec already has required chars encoded diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/metaface-1.2.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/metaface-1.2.5.tm index 4c88cb16..ebcf579e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/metaface-1.2.5.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/metaface-1.2.5.tm @@ -1,6411 +1,6411 @@ -package require dictutils -package provide metaface [namespace eval metaface { - variable version - set version 1.2.5 -}] - - - - -#example datastructure: -#$_ID_ -#{ -#i -# { -# this -# { -# {16 ::p::16 item ::>x {}} -# } -# role2 -# { -# {17 ::p::17 item ::>y {}} -# {18 ::p::18 item ::>z {}} -# } -# } -#context {} -#} - -#$MAP -#invocantdata {16 ::p::16 item ::>x {}} -#interfaces {level0 -# { -# api0 {stack {123 999}} -# api1 {stack {333}} -# } -# level0_default api0 -# level1 -# { -# } -# level1_default {} -# } -#patterndata {patterndefaultmethod {}} - - -namespace eval ::p::predator {} -#temporary alternative to ::p::internals namespace. -# - place predator functions here until ready to replace internals. - - -namespace eval ::p::snap { - variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks. -} - - - - -# not called directly. Retrieved using 'info body ::p::predator::getprop_template' -#review - why use a proc instead of storing it as a string? -proc ::p::predator::getprop_template {_ID_ args} { - set OID [lindex [dict get $_ID_ i this] 0 0] - if {"%varspace%" eq ""} { - set ns ::p::${OID} - } else { - if {[string match "::*" "%varspace%"]} { - set ns "%varspace%" - } else { - set ns ::p::${OID}::%varspace% - } - } - - - if {[llength $args]} { - #lassign [lindex $invocant 0] OID alias itemCmd cmd - if {[array exists ${ns}::o_%prop%]} { - #return [set ${ns}::o_%prop%($args)] - if {[llength $args] == 1} { - return [set ::p::${OID}::o_%prop%([lindex $args 0])] - } else { - return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]] - } - } else { - set val [set ${ns}::o_%prop%] - - set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] - if {$rType eq "object"} { - #return [$val . item {*}$args] - return [$val {*}$args] - } else { - #treat as list? - return [lindex $val $args] - } - } - } else { - return [set ${ns}::o_%prop%] - } -} - - -proc ::p::predator::getprop_template_immediate {_ID_ args} { - if {[llength $args]} { - if {[array exists %ns%::o_%prop%]} { - return [set %ns%::o_%prop%($args)] - } else { - set val [set %ns%::o_%prop%] - set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] - if {$rType eq "object"} { - #return [$val . item {*}$args] - #don't assume defaultmethod named 'item'! - return [$val {*}$args] - } else { - #treat as list? - return [lindex $val $args] - } - } - } else { - return [set %ns%::o_%prop%] - } -} - - - - - - - - -proc ::p::predator::getprop_array {_ID_ prop args} { - set OID [lindex [dict get $_ID_ i this] 0 0] - - #upvar 0 ::p::${OID}::o_${prop} prop - #1st try: assume array - if {[catch {array get ::p::${OID}::o_${prop}} result]} { - #treat as list (why?) - #!review - if {[info exists ::p::${OID}::o_${prop}]} { - array set temp [::list] - set i 0 - foreach element ::p::${OID}::o_${prop} { - set temp($i) $element - incr i - } - set result [array get temp] - } else { - error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" - } - } - return $result -} - -proc ::p::predator::setprop_template {prop _ID_ args} { - set OID [lindex [dict get $_ID_ i this] 0 0] - if {"%varspace%" eq ""} { - set ns ::p::${OID} - } else { - if {[string match "::*" "%varspace%"]} { - set ns "%varspace%" - } else { - set ns ::p::${OID}::%varspace% - } - } - - - if {[llength $args] == 1} { - #return [set ::p::${OID}::o_%prop% [lindex $args 0]] - return [set ${ns}::o_%prop% [lindex $args 0]] - - } else { - if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { - #treat attempt to perform indexed write to nonexistant var, same as indexed write to array - - #2 args - single index followed by a value - if {[llength $args] == 2} { - return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] - } else { - #multiple indices - #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] - return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] - } - } else { - #treat as list - return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] - } - } -} - -#-------------------------------------- -#property read & write traces -#-------------------------------------- - - -proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} { - - #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' " - - #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain. - - if {[llength $idx]} { - if {[llength $idx] == 1} { - set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx] - } else { - lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx] - } - return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value - } else { - if {![info exists $refname]} { - set $refname [$get_cmd $_ID_ {*}$indices] - } else { - set newval [$get_cmd $_ID_ {*}$indices] - if {[set $refname] ne $newval} { - set $refname $newval - } - } - return - } -} - - - - -proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} { - #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname - #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" - - - #derive the name of the write command from the ref var. - set indices [lassign [split [namespace tail $refname] +] prop] - - - #assert - we will never have both a list in indices and an idx value - if {[llength $indices] && ($idx ne "")} { - #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x - #review - are there any datastructures which would/should allow this? - #this assertion is really just here as a sanity check for now - error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" - } - - #upvar #0 ::p::${OID}::_meta::map MAP - #puts "-->propref_trace_write map: $MAP" - - #temporarily deactivate refsync trace - #puts stderr -->1>--removing_trace_o_${field} -### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] - - #we need to catch, and re-raise any error that we may receive when writing the property - # because we have to reinstate the propvar_write_TraceHandler after the call. - #(e.g there may be a propertywrite handler that deliberately raises an error) - - set excludesync_refs $refname - set cmd ::p::${OID}::(SET)$prop - - - set f_error 0 - if {[catch { - - if {![llength $indices]} { - if {[string length $idx]} { - $cmd $_ID_ $idx [set ${refname}($idx)] - #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] - - } else { - $cmd $_ID_ [set $refname] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] - } - } else { - #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" - $cmd $_ID_ {*}$indices [set $refname] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices - } - - } result]} { - set f_error 1 - } - - - - - #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write - #reactivate refsync trace - #puts stderr "****** reactivating refsync trace on o_$field" - #puts stderr -->2>--reactivating_trace_o_${field} - ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] - - - if {$f_error} { - #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. - # ? return -code error $errMsg ? -errorinfo - - #!quick n dirty - #error $errorMsg - return -code error -errorinfo $::errorInfo $result - } else { - return $result - } -} - - - - - -proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { - #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'" - #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array') - - set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set - - #set updated_value [::p::predator::getprop_array $prop $_ID_] - #puts stderr "-->array_Trace updated_value:$updated_value" - if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} { - puts stderr "-->propref_trace_array error $errm" - array set $refname {} - } - - #return value ignored for -} - - -#-------------------------------------- -# -proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - - - #don't rely on variable name passed by trace - may have been 'upvar'ed - set refvar ::p::${OID}::_ref::__OBJECT - - #puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar" - - set iflist [dict get $MAP interfaces level0] - - set plist [list] - - #!todo - get propertylist from cache on object(?) - foreach IFID [lreverse $iflist] { - dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { - #lassign $pdef v - if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} { - if {[array exists ::p::${OID}::o_${prop}]} { - lappend plist $prop [array get ::p::${OID}::o_${prop}] - } else { - #ignore - array only represents properties that have been set. - #error "property $v is not set" - #!todo - unset corresponding items in $refvar if needed? - } - } - } - } - array set $refvar $plist -} - - -proc ::p::predator::object_read_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - #don't rely on variable name passed by trace. - set refvar ::p::${OID}::_ref::__OBJECT - - #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" - - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set IID "" - foreach id [lreverse $iflist] { - if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - - if {[string length $IID]} { - #property - if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { - puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" - } - } else { - #method - error "property '$idx' not found" - } -} - - -proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd - - #!todo - ??? - - if {![llength [info commands ::p::${OID}::$idx]]} { - error "no such method or property: '$idx'" - } else { - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set found 0 - foreach id [lreverse $iflist] { - if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set found 1 - break - } - } - - if {$found} { - unset ::p::${OID}::o_$idx - } else { - puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" - } - } -} - - -proc ::p::predator::object_write_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - #don't rely on variable name passed by trace. - set refvar ::p::${OID}::_ref::__OBJECT - #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" - - - if {![llength [info commands ::p::${OID}::$idx]]} { - #!todo - create new property in interface upon attempt to write to non-existant? - # - or should we require some different kind of object-reference for that? - array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx - error "no such method or property: '$idx'" - } else { - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set IID "" - foreach id [lreverse $iflist] { - if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - - #$IID is now topmost interface in default iStack which has this property - - if {[string length $IID]} { - #write to defined property - - ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] - } else { - #!todo - allow write of method body back to underlying object? - #attempted write to 'method' ..undo(?) - array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx - error "cannot write to method '$idx'" - #for now - disallow - } - } - -} - - - -proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} { - #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname - - set refindices [lassign [split [namespace tail $refname] +] prop] - #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop - #if there is no PropertyUnset command - we unset the underlying variable directly - - trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] - - - if {[catch { - - #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value - #i.e - if {[llength $refindices] && [string length $idx]} { - puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" - error "unexpected call to propref_trace_unset" - } - - - upvar #0 ::p::${OID}::_meta::map MAP - - set iflist [dict get $MAP interfaces level0] - #find topmost interface containing this $prop - set IID "" - foreach id [lreverse $iflist] { - if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - if {![string length $IID]} { - error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" - } - - - - - - - if {[string length $idx]} { - #eval "$_alias ${unset_}$field $idx" - #what happens to $refindices??? - - - #!todo varspace - - if {![llength $refindices]} { - #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - unset ::p::${OID}::o_${prop}($idx) - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx - } - - - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx - } else { - #assert - won't get here - error 1a - - } - - } else { - if {[llength $refindices]} { - #error 2a - #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - #review - what about list-type property? - #if {[array exists ::p::${OID}::o_${prop}]} ??? - unset ::p::${OID}::o_${prop}($refindices) - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices - } - - - - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices - - - } else { - #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - #ref is not of form prop+x etc and no idx in the trace - this is a plain unset - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - unset ::p::${OID}::o_${prop} - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" - } - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} - - } - } - - - - - } errM]} { - #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" - set ruler [string repeat - 80] - puts stderr "\t$ruler" - puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - puts stderr "\t$ruler" - puts stderr $errM - puts stderr "\t$ruler" - - } else { - #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - #puts stderr "*@*@*@*@ end propref_trace_unset - no error" - } - - trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] - - -} - - - - -proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} { - - #Do not use 'info exists' (avoid triggering read trace) - use info vars - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - #puts " **> lappending '::p::REF::${OID}::$prop'" - lappend refvars ::p::${OID}::_ref::$prop - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] - - - - if {[string length $triggeringRef]} { - set idx [lsearch -exact $refvars $triggeringRef] - if {$idx >= 0} { - set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] - } - } - if {![llength $refvars]} { - #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" - return - } - - - #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset - # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" - if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { - #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" - puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" - } - - - puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " - - - - upvar $vtraced SYNCVARIABLE - - - #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars - array set traces [::list] - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - if {$ops in {read write unset array}} { - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } - } - } - } - - - - - if {[array exists SYNCVARIABLE]} { - - #underlying variable is an array - we are presumably unsetting just an element - set vtracedIsArray 1 - } else { - #!? maybe the var was an array - but it's been unset? - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - #some things we don't want to repeat for each refvar in case there are lots of them.. - - #set triggeringRefIdx $vidx - - if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { - set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] - } else { - set triggering_indices [list] - } - - - - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "--- unset branch refvar:$refvar" - - - - if {[llength $vidx]} { - #trace called with an index - must be an array - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #!todo - add test - if {$vidx eq [lrange [split $reftail +] 1 end]} { - #unset if indices match - error "untested, possibly unused branch spuds1" - #puts "1111111111111111111111111" - unset $refvar - } - } else { - #test exists - #!todo - document which one - - #see if we succeeded in unsetting this element in the underlying variables - #(may have been blocked by a PropertyUnset body) - set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] - #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" - if {$element_exists} { - #do nothing it wasn't actually unset - } else { - #puts "JJJJJ unsetting ${refvar}($vidx)" - unset ${refvar}($vidx) - } - } - } - - - - - - } else { - - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #check indices of triggering refvar match this refvars indices - - - if {$reftail eq [namespace tail $triggeringRef]} { - #!todo - add test - error "untested, possibly unused branch spuds2" - #puts "222222222222222222" - unset $refvar - } else { - - #error "untested - branch spuds2a" - - - } - - } else { - #!todo -add test - #reference is directly to property var - error "untested, possibly unused branch spuds3" - #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? - puts "\t33333333333333333333" - - if {[string length $triggeringRefIdx]} { - unset $refvar($triggeringRefIdx) - } - } - } - - } - - - - - #!todo - understand. - #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" - #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" - trace add variable $rv $ops $cmd - } - } - - - - - -} - - -proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} { - - upvar $vtraced SYNCVARIABLE - - set refvars [::list] - #Do not use 'info exists' (avoid triggering read trace) - use info vars - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - lappend refvars ::p::${OID}::_ref::$prop - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] - - - - #short_circuit breaks unset traces for array elements (why?) - - - if {![llength $refvars]} { - #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" - return - } else { - puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" - } - - if {[catch { - - - - #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars - array set traces [::list] - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - if {$ops in {read write unset array}} { - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } - } - } - } - - - - - if {[array exists SYNCVARIABLE]} { - - #underlying variable is an array - we are presumably unsetting just an element - set vtracedIsArray 1 - } else { - #!? maybe the var was an array - but it's been unset? - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - #some things we don't want to repeat for each refvar in case there are lots of them.. - set triggeringRefIdx $vidx - - - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "--- unset branch refvar:$refvar" - - - - if {[llength $vidx]} { - #trace called with an index - must be an array - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #!todo - add test - if {$vidx eq [lrange [split $reftail +] 1 end]} { - #unset if indices match - error "untested, possibly unused branch spuds1" - #puts "1111111111111111111111111" - unset $refvar - } - } else { - #test exists - #!todo - document which one - - #see if we succeeded in unsetting this element in the underlying variables - #(may have been blocked by a PropertyUnset body) - set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] - #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" - if {$element_exists} { - #do nothing it wasn't actually unset - } else { - #puts "JJJJJ unsetting ${refvar}($vidx)" - unset ${refvar}($vidx) - } - } - } - - - - - - } else { - - foreach refvar $refvars { - set reftail [namespace tail $refvar] - unset $refvar - - } - - } - - - - - #!todo - understand. - #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" - #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" - trace add variable $rv $ops $cmd - } - } - - } errM]} { - set ruler [string repeat * 80] - puts stderr "\t$ruler" - puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" - puts stderr "\t$ruler" - puts stderr $::errorInfo - puts stderr "\t$ruler" - - } - -} - -proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} { - error hmmmmm - upvar $vtraced SYNCVARIABLE - #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " - set refvars [::list] - - #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references - #assert triggeringRef is in the list - if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { - error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" - } - set refposn [lsearch -exact $refvars $triggeringRef] - #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 - set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] - if {![llength $refvars]} { - #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" - return [list refs_updates [list]] - } - - #suppress the propref_trace_* traces on all refvars - array set traces [::list] - array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." - #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync - #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? - #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - - - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } else { - #all other traces are 'external' - lappend external_traces($rv) $tinfo - #trace remove variable $rv $ops $cmd - } - - } - } - #-------------------------------------------------------------------------------------------------------------------------- - if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { - if {![info exists SYNCVARIABLE]} { - error "WARNING: REVIEW why does $vartraced not exist here?" - } - #either the underlying variable is an array - # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern - set treat_vtraced_as_array 1 - } else { - set treat_vtraced_as_array 0 - } - - set refs_updated [list] - set refs_deleted [list] ;#unset due to index no longer being relevant - if {$treat_vtraced_as_array} { - foreach refvar $refvars { - #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" - set refvar_tail [namespace tail $refvar] - if {[string match "${prop}+*" $refvar_tail]} { - #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y - set ref_indices [lrange [split $refvar_tail +] 1 end] - if {[llength $indices]} { - if {[llength $indices] == 1} { - if {[lindex $ref_indices 0] eq [lindex $indices 0]} { - #error "untested xxx-a" - set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] - lappend refs_updated $refvar - } else { - #test exists - #error "xxx-ok single index" - #updating a different part of the property - nothing to do - } - } else { - #nested index - if {[lindex $ref_indices 0] eq [lindex $indices 0]} { - if {[llength $ref_indices] == 1} { - #error "untested xxx-b1" - set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] - } else { - #assert llength $ref_indices > 1 - #NOTE - we cannot test index equivalence reliably/simply just by comparing indices - #compare by value - - if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { - #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" - if {[set $refvar] ne $possiblyNewVal} { - set $refvar $possiblyNewVal - } - } else { - #fail to retrieve underlying value corrsponding to these $indices - unset $refvar - } - } - } else { - #test exists - #error "untested xxx-ok deepindex" - #updating a different part of the property - nothing to do - } - } - } else { - error "untested xxx-c" - - } - - } else { - #refvar to update is plain e.g ::p::${OID}::_ref::${prop} - if {[llength $indices]} { - if {[llength $indices] == 1} { - set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] - } else { - lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] - } - lappend refs_updated $refvar - } else { - error "untested yyy" - set $refvar $SYNCVARIABLE - } - } - } - } else { - #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) - # - foreach refvar $refvars { - #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" - set refvar_tail [namespace tail $refvar] - if {[string match "${prop}+*" $refvar_tail]} { - #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y - set ref_indices [lrange [split $refvar_tail +] 1 end] - - if {[llength $indices]} { - #see if this update would affect this curried ref - #1st see if we can short-circuit our comparison based on numeric-indices - if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { - #both sets of indices are purely numeric (no end end-1 etc) - set rlen [llength $ref_indices] - set ilen [llength $indices] - set minlen [expr {min($rlen,$ilen)}] - set matched_firstfew_indices 1 ;#assume the best - for {set i 0} {$i < $minlen} {incr i} { - if {[lindex $ref_indices $i] ne [lindex $indices $i]} { - break ;# - } - } - if {!$matched_firstfew_indices} { - #update of this refvar not required - #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" - break ;#break to next refvar in the foreach loop - } - } - #failed to short-circuit - - #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here - set newval [lindex $SYNCVARIABLE $ref_indices] - if {[set $refvar] ne $newval} { - set $refvar $newval - lappend refs_updated $refvar - } - - } else { - #we must be updating the entire variable - so this curried ref will either need to be updated or unset - set newval [lindex $SYNCVARIABLE $ref_indices] - if {[set ${refvar}] ne $newval} { - set ${refvar} $newval - lappend refs_updated $refvar - } - } - } else { - #refvar to update is plain e.g ::p::${OID}::_ref::${prop} - if {[llength $indices]} { - #error "untested zzz-a" - set newval [lindex $SYNCVARIABLE $indices] - if {[lindex [set $refvar] $indices] ne $newval} { - lset ${refvar} $indices $newval - lappend refs_updated $refvar - } - } else { - if {[set ${refvar}] ne $SYNCVARIABLE} { - set ${refvar} $SYNCVARIABLE - lappend refs_updated $refvar - } - } - - } - - } - } - #-------------------------------------------------------------------------------------------------------------------------- - - #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - if {$rv ni $refs_deleted} { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - } - foreach rv [array names external_traces] { - if {$rv ni $refs_deleted} { - foreach tinfo $external_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - #trace add variable $rv $ops $cmd - } - } - } - - - return [list updated_refs $refs_updated] -} - -#purpose: update all relevant references when context variable changed directly -proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { - #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. - #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler - - upvar $vtraced SYNCVARIABLE - #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" - set t_info [trace vinfo $vtraced] - foreach t_spec $t_info { - set t_ops [lindex $t_spec 0] - if {$op in $t_ops} { - puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" - } - } - - #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- - #vtype = array | array-item | list | simple - - set refvars [::list] - - ############################ - #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! - #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) - #The alternative 'info vars' does not trigger traces - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - #puts " **> lappending '::p::REF::${OID}::$prop'" - lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - } - ############################ - - #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references - - - if {![llength $refvars]} { - #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" - return - } - - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars - array set predator_traces [::list] - #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. - #ie for something like 'trace add variable someref {write read array} somefunc' - # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace - array set external_read_traces [::list] ;#pure read traces the library user may have added - array set external_readetc_traces [::list] ;#read + something else traces the library user may have added - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - #if {$ops in {read write unset array}} {} - - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend predator_traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } else { - #other traces - # puts "##trace $tinfo" - if {"read" in $ops} { - if {[llength $ops] == 1} { - #pure read - - lappend external_read_traces($rv) $tinfo - trace remove variable $rv $ops $cmd - } else { - #mixed operation trace - remove and reinstall without the 'read' - lappend external_readetc_traces($rv) $tinfo - set other_ops [lsearch -all -inline -not $ops "read"] - trace remove variable $rv $ops $cmd - #reinstall trace for non-read operations only - trace add variable $rv $other_ops $cmd - } - } - } - } - } - - - if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { - #either the underlying variable is an array - # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern - set vtracedIsArray 1 - } else { - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" - #puts "**write*********** refvars: $refvars" - - #!todo? unroll foreach into multiple foreaches within ifs? - #foreach refvar $refvars {} - - - #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" - if {[string length $vidx]} { - #indexable - if {$vtracedIsArray} { - - foreach refvar $refvars { - #puts stderr " - - a refvar $refvar vidx: $vidx" - set tail [namespace tail $refvar] - if {[string match "${prop}+*" $tail]} { - #refvar is curried - #only set if vidx matches curried index - #!todo -review - set idx [lrange [split $tail +] 1 end] - if {$idx eq $vidx} { - set newval [set SYNCVARIABLE($vidx)] - if {[set $refvar] ne $newval} { - set ${refvar} $newval - } - #puts stderr "=a.1=> updated $refvar" - } - } else { - #refvar is simple - set newval [set SYNCVARIABLE($vidx)] - if {![info exists ${refvar}($vidx)]} { - #new key for this array - #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " - array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] - } else { - set oldval [set ${refvar}($vidx)] - if {$oldval ne $newval} { - #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " - array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] - } - } - #puts stderr "=a.2=> updated ${refvar} $vidx" - } - } - - - - } else { - - - foreach refvar $refvars { - upvar $refvar internal_property_reference - #puts stderr " - - b vidx: $vidx" - - #!? could be object not list?? - #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? - #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) - #There would still be an edge case of an initial write of a list of objects of length 1. - if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { - error "untested review!" - #the o_prop is object-shaped - #assumes object has a defaultmethod which accepts indices - set newval [[set $SYNCVARIABLE] {*}$vidx] - - } else { - set newval [lindex $SYNCVARIABLE {*}$vidx] - #if {[set $refvar] ne $newval} { - # set $refvar $newval - #} - if {$internal_property_reference ne $newval} { - set internal_property_reference $newval - } - - } - #puts stderr "=b=> updated $refvar" - } - - - } - - - - } else { - #no vidx - - if {$vtracedIsArray} { - - - foreach refvar $refvars { - set targetref_tail [namespace tail $refvar] - set targetref_is_indexed [string match "${prop}+*" $targetref_tail] - - - #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" - if {$targetref_is_indexed} { - #curried array item ref of the form ${prop}+x or ${prop}+x+y etc - - #unindexed write on a property that is acting as an array.. - - #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. - - #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). - # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. - puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" - } else { - #How do we know what to write to array ref? - puts stderr "\tc.2 WARNING: unimplemented/unused?" - #error no_tests_for_branch - - #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation - #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate - array unset ${refvar} - array set ${refvar} [array get SYNCVARIABLE] - } - } - - - - } else { - foreach refvar $refvars { - #puts stderr "\t\t_________________[namespace current]" - set targetref_tail [namespace tail $refvar] - upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail - set targetref_is_indexed [string match "${prop}+*" $targetref_tail] - - if {$targetref_is_indexed} { - #puts "XXXXXXXXX vtraced:$vtraced" - #reference curried with index(es) - #we only set indexed refs if value has changed - # - this not required to be consistent with standard list-containing variable traces, - # as normally list elements can't be traced seperately anyway. - # - - - #only bother checking a ref if no setVia index - # i.e some operation on entire variable so need to test synchronisation for each element-ref - set targetref_indices [lrange [split $targetref_tail +] 1 end] - set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] - #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" - if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { - set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal - #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" - } - - - } else { - #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! - - #puts stderr "- d2 set" - #puts "refvar: [set $refvar]" - #puts "SYNCVARIABLE: $SYNCVARIABLE" - - #if {[set $refvar] ne $SYNCVARIABLE} { - # set $refvar $SYNCVARIABLE - #} - if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { - set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE - } - - } - } - - - } - - } - - - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names predator_traces] { - foreach tinfo $predator_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - - foreach rv [array names external_traces] { - foreach tinfo $external_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - - - -} - -# end propvar_write_TraceHandler - - - - - - - - - - - - - - - - -# - -#returns 0 if method implementation not present for interface -proc ::p::predator::method_chainhead {iid method} { - #Interface proc - # examine the existing command-chain - set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex) - set cmdchain [list] - - set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}] - set maxversion 0 - #loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob. - foreach test [lsort -dictionary $candidates] { - set c [namespace tail $test] - if {[regexp $re $c _match version]} { - lappend cmdchain $c - if {$version > $maxversion} { - set maxversion $version - } - } - } - return $maxversion -} - - - - - -#this returns a script that upvars vars for all interfaces on the calling object - -# - must be called at runtime from a method -proc ::p::predator::upvar_all {_ID_} { - #::set OID [lindex $_ID_ 0 0] - ::set OID [::lindex [::dict get $_ID_ i this] 0 0] - ::set decl {} - #[set ::p::${OID}::_meta::map] - #[dict get [lindex [dict get $_ID_ i this] 0 1] map] - - ::upvar #0 ::p::${OID}::_meta::map MAP - #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" - #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] - - ::foreach ifid [dict get $MAP interfaces level0] { - if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} { - ::array unset nsvars - ::array set nsvars [::list] - ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { - ::set varspace [::dict get $vinfo varspace] - ::lappend nsvars($varspace) $vname - } - #nsvars now contains vars grouped by varspace. - - ::foreach varspace [::array names nsvars] { - if {$varspace eq ""} { - ::set ns ::p::${OID} - } else { - if {[::string match "::*" $varspace]} { - ::set ns $varspace - } else { - ::set ns ::p::${OID}::$varspace - } - } - - ::append decl "namespace upvar $ns " - ::foreach vname [::set nsvars($varspace)] { - ::append decl "$vname $vname " - } - ::append decl " ;\n" - } - ::array unset nsvars - } - } - ::return $decl -} - -#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator) -proc ::p::predator::runtime_vardecls {} { - set result "::eval \[::p::predator::upvar_all \$_ID_\]" - #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" - - #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" - #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" - #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" - return $result -} - - - - - - -#OBSOLETE!(?) - todo - move stuff out of here. -proc ::p::predator::compile_interface {IFID caller_ID_} { - upvar 0 ::p::${IFID}:: IFACE - - #namespace eval ::p::${IFID} { - # namespace ensemble create - #} - - #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables - - namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces - - #set varDecls {} - #if {[llength $o_variables]} { - # #puts "*********!!!! $vlist" - # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] " - # foreach vdef $o_variables { - # append varDecls "[lindex $vdef 0] [lindex $vdef 0] " - # } - # append varDecls \n - #} - - #runtime gathering of vars from other interfaces. - #append varDecls [runtime_vardecls] - - set varDecls [runtime_vardecls] - - - - #implement methods - - #!todo - avoid globs on iface array? maintain list of methods in another slot? - #foreach {n mname} [array get IFACE m-1,name,*] {} - - - #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. - - - - #implement property getters/setters/unsetters - #'setter' overrides - #pw short for propertywrite - foreach {n property} [array get IFACE pw,name,*] { - if {[string length $property]} { - #set property [lindex [split $n ,] end] - - #!todo - next_script - #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] - - set maxversion [::p::predator::method_chainhead $IFID (SET)$property] - set chainhead [expr {$maxversion + 1}] - set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 - - set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? - - set body $IFACE(pw,body,$property) - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set body $varDecls\n[dict get $processed body] - #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" - } - - #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - - - set maxversion [::p::predator::method_chainhead $IFID $property] - set headid [expr {$maxversion + 1}] - - proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body - - interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid - - #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body - } - } - #'unset' overrides - - dict for {property handler_info} $o_propertyunset_handlers { - - set body [dict get $handler_info body] - set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array - - set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (UNSET)$property.$headid - - set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? - - - - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set body $varDecls\n[dict get $processed body] - #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body" - - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - - - - #implement - #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) - if {[string trim $arraykeypattern] eq ""} { - set arraykeypattern "_dontcare_" - } - proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body - - - #chainhead pointer - interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid - } - - - - interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) - - #the usual case will have no destructor - so use info exists to check. - - if {[info exists ::p::${IFID}::_iface::o_destructor_body]} { - #!todo - chained destructors (support @next@). - #set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID] - set next NEXT - - set body [set ::p::${IFID}::_iface::o_destructor_body] - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set body $varDecls\n[dict get $processed body] - #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body" - } - #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body] - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - - proc ::p::${IFID}::___system___destructor _ID_ $body - } - - - if {[info exists o_unknown]} { - #use 'apply' somehow? - interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown - - #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] - } - - - return -} - - - - - - - -#'info args' - assuming arbitrary chain of 'interp aliases' -proc ::p::predator::command_info_args {cmd} { - if {[llength [set next [interp alias {} $cmd]]]} { - set curriedargs [lrange $next 1 end] - - if {[catch {set arglist [info args [lindex $next 0]]}]} { - set arglist [command_info_args [lindex $next 0]] - } - #trim curriedargs - return [lrange $arglist [llength $curriedargs] end] - } else { - info args $cmd - } -} - - -proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { - if {[llength $args]} { - tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args - } else { - if {[llength $nextArgs] > 1} { - set argVals [::list] - set i 0 - foreach arg [lrange $nextArgs 1 end] { - upvar 1 $arg $i - if {$arg eq "args"} { - #need to check if 'args' is actually available in caller - if {[info exists $i]} { - set argVals [concat $argVals [set $i]] - } - } else { - lappend argVals [set $i] - } - } - tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals - } else { - tailcall ::p::${IFID}::_iface::$mname $_ID_ - } - } -} - -#---------------------------------------------------------------------------------------------- -proc ::p::predator::next_script {IFID method caller caller_ID_} { - - if {$caller eq "(CONSTRUCTOR).1"} { - return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}] - } elseif {$caller eq "$method.1"} { - #delegate to next interface lower down the stack which has a member named $method - return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] - } elseif {[string match "(GET)*.2" $caller]} { - # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. - - #jmn - set prop [string trimright $caller 1234567890] - set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing . - - if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} { - #return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}] - return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] - } else { - #we can actually have a property read without a property or a method of that name - but it could also match the name of a method. - # (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something) - return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] - } - } elseif {[string match "(SET)*.2" $caller]} { - return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] - } else { - #this branch will also handle (SET)*.x and (GET)*.x where x >2 - - #puts stdout "............next_script IFID:$IFID method:$method caller:$caller" - set callerid [string range $caller [string length "$method."] end] - set nextid [expr {$callerid - 1}] - - if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} { - #not a proc directly on this interface - presumably an alias made by something like linkcopy_interface. - #puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid" - set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid] - } - - return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] - } -} - -proc ::p::predator::do_next_if {_ID_ IFID method args} { - #puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' (((" - - #set invocants [dict get $_ID_ i] - #set this_invocantdata [lindex [dict get $invocants this] 0] - #lassign $this_invocantdata OID this_info - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set interfaces [dict get $MAP interfaces level0] - set patterninterfaces [dict get $MAP interfaces level1] - - set L0_posn [lsearch $interfaces $IFID] - if {$L0_posn == -1} { - error "(::p::predator::do_next_if) called with interface not present at level0 for this object" - } elseif {$L0_posn > 0} { - #set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack - set lower_interfaces [lrange $interfaces 0 $L0_posn-1] - - foreach if_sub [lreverse $lower_interfaces] { - if {[string match "(GET)*" $method]} { - #do not test o_properties here! We need to call even if there is no underlying property on this interface - #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) - # relevant test: higher_order_propertyread_chaining - return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - } elseif {[string match "(SET)*" $method]} { - #must be called even if there is no matching $method in o_properties - return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - } elseif {[string match "(UNSET)*" $method]} { - #review untested - #error "do_next_if (UNSET) untested" - #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'" - return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - - } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} { - if {[llength $args]} { - #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args" - - #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args - - #!todo - handle case where llength $args is less than number of args for subinterface command - #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set) - - #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature) - set head [interp alias {} ::p::${if_sub}::_iface::$method] - set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc - set argx [list] - foreach a $nextArgs { - lappend argx "\$a" - } - - #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared - - if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} { - tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args - } else { - #todo - upvars required for tail end of arglist - tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args - } - - } else { - #auto-set: upvar vars from calling scope - #!todo - robustify? alias not necessarily matching command name.. - set head [interp alias {} ::p::${if_sub}::_iface::$method] - - - set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc - if {[llength $nextArgs] > 1} { - set argVals [::list] - set i 0 - foreach arg [lrange $nextArgs 1 end] { - upvar 1 $arg $i - if {$arg eq "args"} { - #need to check if 'args' is actually available in caller - if {[info exists $i]} { - set argVals [concat $argVals [set $i]] - } - } else { - lappend argVals [set $i] - } - } - #return [$head $_ID_ {*}$argVals] - tailcall $head $_ID_ {*}$argVals - } else { - #return [$head $_ID_] - tailcall $head $_ID_ - } - } - } elseif {$method eq "(CONSTRUCTOR)"} { - #chained constructors will only get args if the @next@ caller explicitly provided them. - puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" - #return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args] - xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args - } - } - #no interfaces in the iStack contained a matching method. - return - } else { - #no further interfaces in this iStack - return - } -} - - -#only really makes sense for (CONSTRUCTOR) calls. -#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class. -proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { - #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" - - #set invocants [dict get $_ID_ i] - #set this_invocant [lindex [dict get $invocants this] 0] - #lassign $this_invocant OID this_info - #set OID [lindex [dict get $invocants this] 0 0] - #upvar #0 ::p::${OID}::_meta::map map - #lassign [lindex $map 0] OID alias itemCmd cmd - - - set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] - upvar #0 ::p::${caller_OID}::_meta::map callermap - - #set interfaces [lindex $map 1 0] - set patterninterfaces [dict get $callermap interfaces level1] - - set L0_posn [lsearch $patterninterfaces $IFID] - if {$L0_posn == -1} { - error "do_next_pattern_if called with interface not present at level1 for this object" - } elseif {$L0_posn > 0} { - - - set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] - - foreach if_sub [lreverse $lower_interfaces] { - if {$method eq "(CONSTRUCTOR)"} { - #chained constructors will only get args if the @next@ caller explicitly provided them. - #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" - tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args - } - } - #no interfaces in the iStack contained a matching method. - return - } else { - #no further interfaces in this iStack - return - } -} - - - - - -#------------------------------------------------------------------------------------------------ - - - - - -#------------------------------------------------------------------------------------- -####################################################### -####################################################### -####################################################### -####################################################### -####################################################### -####################################################### -####################################################### - - -#!todo - can we just call new_object somehow to create this? - - #until we have a version of Tcl that doesn't have 'creative writing' scope issues - - # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. - # (see http://mini.net/tcl/1030 'Dangers of creative writing') -namespace eval ::p::-1 { - #namespace ensemble create - - namespace eval _ref {} - namespace eval _meta {} - - namespace eval _iface { - variable o_usedby - variable o_open - variable o_constructor - variable o_variables - variable o_properties - variable o_methods - variable o_definition - variable o_varspace - variable o_varspaces - - array set o_usedby [list i0 1] ;#!todo - review - #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? - - set o_open 1 - set o_constructor [list] - set o_variables [list] - set o_properties [dict create] - set o_methods [dict create] - array set o_definition [list] - set o_varspace "" - set o_varspaces [list] - } -} - - -# - -#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}] -interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}] - - -upvar #0 ::p::-1::_iface::o_definition def - - -#! concatenate -> compose ?? -dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}} -proc ::p::-1::Concatenate {_ID_ target args} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - if {![string match "::*" $target]} { - if {[set ns [uplevel 1 {namespace current}]] eq "::"} { - set target ::$target - } else { - set target ${ns}::$target - } - } - #add > character if not already present - set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] - set _target [string map {::> ::} $target] - - set ns [namespace qualifiers $target] - if {$ns eq ""} { - set ns "::" - } else { - namespace eval $ns {} - } - - if {![llength [info commands $target]]} { - #degenerate case - target does not exist - #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone' - #review - should be 'Copy' so it has object state from namespaces and variables? - return [::p::-1::Clone $_ID_ $target {*}$args] - - #set TARGETMAP [::p::predator::new_object $target] - #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd - - } else { - #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] - set TARGETMAP [$target --] - - lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd - - #Merge lastmodified(?) level0 and level1 interfaces. - - } - - return $target -} - - - -#Object's Base-Interface proc with itself as curried invocant. -#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant -#namespace eval ::p::-1 {namespace export Create} -dict set ::p::-1::_iface::o_methods Define {arglist definitions} -#define objects in one step -proc ::p::-1::Define {_ID_ definitions} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias default_method cmd - set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces - set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces - - #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack - #set IFID0 [lindex $interfaces 0] - #set IFID1 [lindex $patterns 0] ;#1st pattern - - #set IFID_TOP [lindex $interfaces end] - set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] - - #set ns ::p::${OID} - - #set script [string map [list %definitions% $definitions] { - # if {[lindex [namespace path] 0] ne "::p::-1"} { - # namespace path [list ::p::-1 {*}[namespace path]] - # } - # %definitions% - # namespace path [lrange [namespace path] 1 end] - # - #}] - - set script [string map [list %id% $_ID_ %definitions% $definitions] { - set ::p::-1::temp_unknown [namespace unknown] - - namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] - - - #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] - - - %definitions% - - - namespace unknown ${::p::-1::temp_unknown} - return - }] - - - - #uplevel 1 $script ;#this would run the script in the global namespace - #run script in the namespace of the open interface, this allows creating of private helper procs - #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack - #namespace inscope ::p::${OID} $script - namespace eval ::p::${OID} $script - #return $cmd -} - - -proc ::p::predator::redirect {func args} { - - #todo - review tailcall - tests? - if {![llength [info commands ::p::-1::$func]]} { - #error "invalid command name \"$func\"" - tailcall uplevel 1 [list ::unknown $func {*}$args] - } else { - tailcall uplevel 1 [list ::p::-1::$func {*}$args] - } -} - - -#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review. -dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}} -proc ::p::-1::Construct {_ID_ argpairs body args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set interfaces [dict get $MAP interfaces level0] - set iid_top [lindex $interfaces end] - namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace - - set ARGSETTER {} - foreach {argname argval} $argpairs { - append ARGSETTER "set $argname $argval\n" - } - #$_self (VIOLATE) $ARGSETTER$body - - set body $ARGSETTER\n$body - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls\n[dict get $processed body] - # puts stderr "\t runtime_vardecls in Construct $varDecls" - } - - set next "\[error {next not implemented}\]" - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - - #namespace eval ::p::${iid_top} $body - - #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] - #does this handle Varspace before constructor? - return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] -} - - - - - -#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects -namespace eval ::p::3 {} -proc ::p::3::_create {child {OID "-2"}} { - #puts stderr "::p::3::_create $child $OID" - set _child [string map {::> ::} $child] - if {$OID eq "-2"} { - #set childmapdata [::p::internals::new_object $child] - #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] - set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - } else { - set child_ID $OID - #set _childmap [::p::internals::new_object $child "" $child_ID] - ::p::internals::new_object $child "" $child_ID - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - } - - #-------------- - - set oldinterfaces [dict get $CHILDMAP interfaces] - dict set oldinterfaces level0 [list 2] - set modifiedinterfaces $oldinterfaces - dict set CHILDMAP interfaces $modifiedinterfaces - - #-------------- - - - - - #puts stderr ">>>> creating alias for ::p::$child_ID" - #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" - - #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! - #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] - #puts stderr ">>>[interp alias {} ::p::$child_ID]" - - - - #--------------- - namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties - foreach method [dict keys $o_methods] { - #todo - change from interp alias to context proc - interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method - } - #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] - #implement property even if interface already compiled because we need to create defaults for each new child obj. - # also need to add alias on base interface - #make sure we are only implementing properties from the current CREATOR - dict for {prop pdef} $o_properties { - #lassign $pdef prop default - interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop - interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop - - } - ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] - #--------------- - #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" - return $child -} - -#configure -prop1 val1 -prop2 val2 ... -dict set ::p::-1::_iface::o_methods Configure {arglist args} -proc ::p::-1::Configure {_ID_ args} { - - #!todo - add tests. - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd this - - if {![expr {([llength $args] % 2) == 0}]} { - error "expected even number of Configure args e.g '-property1 value1 -property2 value2'" - } - - #Do a separate loop to check all the arguments before we run the property setting loop - set properties_to_configure [list] - foreach {argprop val} $args { - if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} { - error "expected Configure args in the form: '-property1 value1 -property2 value2'" - } - lappend properties_to_configure [string range $argprop 1 end] - } - - #gather all valid property names for all level0 interfaces in the relevant interface stack - set valid_property_names [list] - set iflist [dict get $MAP interfaces level0] - foreach id [lreverse $iflist] { - set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]] - foreach if_prop $interface_property_names { - if {$if_prop ni $valid_property_names} { - lappend valid_property_names $if_prop - } - } - } - - foreach argprop $properties_to_configure { - if {$argprop ni $valid_property_names} { - error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names" - } - } - - set top_IID [lindex $iflist end] - #args ok - go ahead and set all properties - foreach {prop val} $args { - set property [string range $prop 1 end] - #------------ - #don't use property ref unnecessarily - leaves property refs hanging around which traces need to update - #ie don't do this here: set [$this . $property .] $val - #------------- - ::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val] - } - return -} - - - - - - -dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid} -proc ::p::-1::AddPatternInterface {_ID_ iid} { - #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" - if {![string is integer -strict $iid]} { - error "adding interface by name not yet supported. Please use integer id" - } - - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - #lassign [lindex $invocant 0] OID alias itemCmd cmd - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces - - - - #it is theoretically possible to have the same interface present multiple times in an iStack. - # #!todo -review why/whether this is useful. should we disallow it and treat as an error? - - lappend existing_ifaces $iid - #lset map {1 1} $existing_ifaces - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 $existing_ifaces - dict set MAP interfaces $extracted_sub_dict - - #lset invocant {1 1} $existing_ifaces - -} - - -#!todo - update usedby ?? -dict set ::p::-1::_iface::o_methods AddInterface {arglist iid} -proc ::p::-1::AddInterface {_ID_ iid} { - #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" - if {![string is integer -strict $iid]} { - error "adding interface by name not yet supported. Please use integer id" - } - - - lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. - set this_invocant [lindex $list_of_invocants_for_role_this 0] - - lassign $this_invocant OID _etc - - upvar #0 ::p::${OID}::_meta::map MAP - set existing_ifaces [dict get $MAP interfaces level0] - - lappend existing_ifaces $iid - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 $existing_ifaces - dict set MAP interfaces $extracted_sub_dict - return [dict get $extracted_sub_dict level0] -} - - - -# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module. -# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist -# and 'CreateOverlay' for the case where the target/child object already exists. -# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence, -# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object. -# 'CreateNew' will raise an error if the target already exists -# 'CreateOverlay' will raise an error if the target object does not exist. -# 'Create' will work in either case. Creating the target if necessary. - - -#simple form: -# >somepattern .. Create >child -#simple form with arguments to the constructor: -# >somepattern .. Create >child arg1 arg2 etc -#complex form - specify more info about the target (dict keyed on childobject name): -# >somepattern .. Create {>child {-id 1}} -#or -# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] -#complex form - with arguments to the contructor: -# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc -dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}} -proc ::p::-1::Create {_ID_ target_spec args} { - #$args are passed to constructor - if {[llength $target_spec] ==1} { - set child $target_spec - set targets [list $child {}] - } else { - set targets $target_spec - } - - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - set invocants [dict get $_ID_ i] - set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) - - foreach {child target_spec_dict} $targets { - #puts ">>>::p::-1::Create $_ID_ $child $args <<<" - - - - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - - - - - #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID" - - #child should already be fully ns qualified (?) - #ensure it is has a pattern-object marker > - #puts stderr ".... $child (nsqual: [namespace qualifiers $child])" - - - lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd - set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces - set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces - #puts "parent: $OID -> child:$child Patterns $patterns" - - #todo - change to dict of interface stacks - set IFID0 [lindex $interfaces 0] - set IFID1 [lindex $patterns 0] ;#1st pattern - - #upvar ::p::${OID}:: INFO - - if {![string match {::*} $child]} { - if {[set ns [uplevel 1 {namespace current}]] eq "::"} { - set child ::$child - } else { - set child ${ns}::$child - } - } - - - #add > character if not already present - set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >] - set _child [string map {::> ::} $child] - - set ns [namespace qualifiers $child] - if {$ns eq ""} { - set ns "::" - } else { - namespace eval $ns {} - } - - - #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls. - set new_interfaces [list] - - if {![llength $patterns]} { - ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child" - #lappend patterns [::p::internals::new_interface $OID] - - #lset invocant {1 1} $patterns - ##update our command because we changed the interface list. - #set IFID1 [lindex $patterns 0] - - #set patterns [list [::p::internals::new_interface $OID]] - - #set patterns [list [::p::internals::new_interface]] - - #set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id - #set patterns [list [set iid [incr ::p::ID]]] - set patterns [list [set iid [::p::get_new_object_id]]] - - #--------- - #set iface [::p::>interface .. Create ::p::ifaces::>$iid] - #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid - - #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation - lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid] - - #--------- - - #puts "??> p::>interface .. Create ::p::ifaces::>$iid" - #puts "??> [::p::ifaces::>$iid --]" - #set [$iface . UsedBy .] - } - set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] - - #if {![llength [info commands $child]]} {} - - if {[namespace which $child] eq ""} { - #normal case - target/child does not exist - set is_new_object 1 - - if {[dict exists $target_spec_dict -id]} { - set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]] - } else { - set childmapdata [::p::internals::new_object $child] - } - lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - - - - #child initially uses parent's level1 interface as it's level0 interface - # child has no level1 interface until PatternMethods or PatternProperties are added - # (or applied via clone; or via create with a parent with level2 interface) - #set child_IFID $IFID1 - - #lset CHILDMAP {1 0} [list $IFID1] - #lset CHILDMAP {1 0} $patterns - - set extracted_sub_dict [dict get $CHILDMAP interfaces] - dict set extracted_sub_dict level0 $patterns - dict set CHILDMAP interfaces $extracted_sub_dict - - #why write back when upvared??? - #review - set ::p::${child_ID}::_meta::map $CHILDMAP - - #::p::predator::remap $CHILDMAP - - #interp alias {} $child {} ::p::internals::predator $CHILDMAP - - #set child_IFID $IFID1 - - #upvar ::p::${child_ID}:: child_INFO - - #!todo review - #set n ::p::${child_ID} - #if {![info exists ${n}::-->PATTERN_ANCHOR]} { - # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" - # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack - # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" - # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] - #} - - set ifaces_added $patterns - - } else { - #overlay/mixin case - target/child already exists - set is_new_object 0 - - #set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1] - set childmapdata [$child --] - - - #puts stderr " *** $cmd .. Create -> target $child already exists!!!" - #puts " **** CHILDMAP: $CHILDMAP" - #puts " ****" - - #puts stderr " ---> Properties: [$child .. Properties . names]" - #puts stderr " ---> Methods: [$child .. Properties . names]" - - lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - - #set child_IFID [lindex $CHILDMAP 1 0 end] - #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} { - # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] - # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP - #} - ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces - #::p::merge_interface $IFID1 $child_IFID - - - set existing_interfaces [dict get $CHILDMAP interfaces level0] - set ifaces_added [list] - foreach p $patterns { - if {$p ni $existing_interfaces} { - lappend ifaces_added $p - } - } - - if {[llength $ifaces_added]} { - #lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added] - set extracted_sub_dict [dict get $CHILDMAP interfaces] - dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added] - dict set CHILDMAP interfaces $extracted_sub_dict - #set ::p::${child_ID}::_meta::map $CHILDMAP ;#why? - #::p::predator::remap $CHILDMAP - } - } - - #do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty - if {$parent_patterndefaultmethod ne ""} { - set child_defaultmethod $parent_patterndefaultmethod - set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata] - lset CHILD_INVOCANTDATA 2 $child_defaultmethod - dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA - #update the child's _ID_ - interp alias {} $child_alias {} ;#first we must delete it - interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}] - - #! object_command was initially created as the renamed alias - so we have to do it again - rename $child_alias $child - trace add command $child rename [list $child .. Rename] - } - #!todo - review - dont we already have interp alias entries for every method/prop? - #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" - - - - - - set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call. - - - - #------------------------------------------------------------------------------------ - #create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail. - # - All variables under the namespace - not just those declared as Variables or Properties - # - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces. - # - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write. - - #NOTE - do not use the objectID as the sole identifier for the snapshot namespace. - # - there may be multiple active snapshots for a single object if it overlays itself during a constructor, - # and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call. - # - we will use an ever-increasing snapshotid to form part of ns_snap - set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create. - - #!todo - this should look at child namespaces (recursively?) - #!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces. - # (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace) - - namespace eval $ns_snap {} - foreach vname [info vars ::p::${child_ID}::*] { - set shortname [namespace tail $vname] - if {[array exists $vname]} { - array set ${ns_snap}::${shortname} [array get $vname] - } elseif {[info exists $vname]} { - set ${ns_snap}::${shortname} [set $vname] - } else { - #variable exists without value (e.g created by 'variable' command) - namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist' - } - } - #------------------------------------------------------------------------------------ - - - - - - - - - - #puts "====>>> ifaces_added $ifaces_added" - set idx 0 - set idx_count [llength $ifaces_added] - set highest_constructor_IFID "" - foreach IFID $ifaces_added { - incr idx - #puts "--> adding iface $IFID " - namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces - - if {[llength $o_varspaces]} { - foreach vs $o_varspaces { - #ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work. - if {[string match "::*" $vs]} { - namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all. - } else { - namespace eval ::p::${child_ID}::$vs {} - } - } - } - - if {$IFID != 2} { - #>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list. - if {![info exists o_usedby(i$child_ID)]} { - set o_usedby(i$child_ID) $child_alias - } - - #compile and close the interface only if it is shared - if {$o_open} { - ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_ - set o_open 0 - } - } - - - - package require struct::set - - set propcmds [list] - foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] { - set cmd [namespace tail $cmd] - #may contain multiple results for same prop e.g (GET)x.3 - set cmd [string trimright $cmd 0123456789] - set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals - lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. - } - set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. - #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. - foreach property $propcmds { - #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n" - interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces - interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property - } - - set propcmds [list] - foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] { - set cmd [namespace tail $cmd] - #may contain multiple results for same prop e.g (GET)x.3 - set cmd [string trimright $cmd 0123456789] - set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals - lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. - } - set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. - #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. - foreach property $propcmds { - interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces - } - - - foreach method [dict keys $o_methods] { - set arglist [dict get $o_methods $method arglist] - set argvals "" - foreach argspec $arglist { - if {[llength $argspec] == 2} { - set a [lindex $argspec 0] - } else { - set a $argspec - } - - if {$a eq "args"} { - append argvals " \{*\}\$args" - } else { - append argvals " \$$a" - } - } - set argvals [string trimleft $argvals] - - #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method - - #this proc directly on the object is not *just* a forwarding proc - # - it provides a context in which the 'uplevel 1' from the running interface proc runs - #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) - - #proc calls the method in the interface - which is an interp alias to the head of the implementation chain - - - proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst { - ::p::${IFID}::_iface::$method \$_ID_ $argvals - }] - - #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] { - # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ - #}] - - - } - - #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] - - #implement property even if interface already compiled because we need to create defaults for each new child obj. - # also need to add alias on base interface - #make sure we are only implementing properties from the current CREATOR - dict for {prop pdef} $o_properties { - set varspace [dict get $pdef varspace] - if {![string length $varspace]} { - set ns ::p::${child_ID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${child_ID}::$varspace - } - } - if {[dict exists $pdef default]} { - if {![info exists ${ns}::o_$prop]} { - #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) - set ${ns}::o_$prop [dict get $pdef default] - } - } - #! May be replaced by a method with the same name - if {$prop ni [dict keys $o_methods]} { - interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop - } - interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop - interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop - } - - - - #variables - #foreach vdef $o_variables { - # if {[llength $vdef] == 2} { - # #there is a default value defined. - # lassign $vdef v default - # if {![info exists ::p::${child_ID}::$v]} { - # set ::p::${child_ID}::$v $default - # } - # } - #} - dict for {vname vdef} $o_variables { - if {[dict exists $vdef default]} { - #there is a default value defined. - set varspace [dict get $vdef varspace] - if {$varspace eq ""} { - set ns ::p::${child_ID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${child_ID}::$varspace - } - } - set ${ns}::$vname [dict get $vdef default] - } - } - - - #!todo - review. Write tests for cases of multiple constructors! - - #We don't want to the run constructor for each added interface with the same set of args! - #run for last one - rely on constructor authors to use @next@ properly? - if {[llength [set ::p::${IFID}::_iface::o_constructor]]} { - set highest_constructor_IFID $IFID - } - - if {$idx == $idx_count} { - #we are processing the last interface that was added - now run the latest constructor found - if {$highest_constructor_IFID ne ""} { - #at least one interface has a constructor - if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} { - #puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP" - if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} { - set constructor_failure 1 - set constructor_errorInfo $::errorInfo ;#cache it immediately. - break - } - } - } - } - - if {[info exists o_unknown]} { - interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown - interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown - - - #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown - #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] - #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown] - } - } - - if {$constructor_failure} { - if {$is_new_object} { - #is Destroy enough to ensure that no new interfaces or objects were left dangling? - $child .. Destroy - } else { - #object needs to be returned to a sensible state.. - #attempt to rollback all interface additions and object state changes! - puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n" - #remove variables from the object's namespace - which don't exist in the snapshot. - set snap_vars [info vars ${ns_snap}::*] - puts "ns_snap '$ns_snap' vars'${snap_vars}'" - foreach vname [info vars ::p::${child_ID}::*] { - set shortname [namespace tail $vname] - if {"${ns_snap}::$shortname" ni "$snap_vars"} { - #puts "--- >>>>> unsetting $shortname " - unset -nocomplain $vname - } - } - - #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces) - #values of vars may also have Changed - #todo - consider traces? what is the correct behaviour? - # - some application traces may have fired before the constructor error occurred. - # Should the rollback now also trigger traces? - #probably yes. - - #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value - foreach vname $snap_vars { - #puts stdout "@@@@@@@@@@@ restoring $vname" - #flush stdout - - - set shortname [namespace tail $vname] - set target ::p::${child_ID}::$shortname - if {$target in [info vars ::p::${child_ID}::*]} { - set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only' - } else { - set present 0 - } - - if {[array exists $vname]} { - #restore 'array' variable - if {!$present} { - array set $target [array get $vname] - } else { - if {[array exists $target]} { - #unset superfluous elements - foreach key [array names $target] { - if {$key ni [array names $vname]} { - array unset $target $key - } - } - #.. and write only elements that have changed. - foreach key [array names $vname] { - if {[set ${target}($key)] ne [set ${vname}($key)]} { - set ${target}($key) [set ${vname}($key)] - } - } - } else { - #target has been changed to a simple variable - unset it and recreate the array. - unset $target - array set $target [array get $vname] - } - } - } elseif {[info exists $vname]} { - #restore 'simple' variable - if {!$present} { - set $target [set $vname] - } else { - if {[array exists $target]} { - #target has been changed to array - unset it and recreate the simple variable. - unset $target - set $target [set $vname] - } else { - if {[set $target] ne [set $vname]} { - set $target [set $vname] - } - } - } - } else { - #restore 'declared' variable - if {[array exists $target] || [info exists $target]} { - unset -nocomplain $target - } - namespace eval ::p::${child_ID} [list variable $shortname] - } - } - } - namespace delete $ns_snap - return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error - } - namespace delete $ns_snap - - } - - - - return $child -} - -dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} -#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied* -# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*) -# Also: Any 'open' interfaces on the parent become closed on clone! -proc ::p::-1::Clone {_ID_ clone args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set invocants [dict get $_ID_ i] - lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd - - set _cmd [string map {::> ::} $cmd] - set tail [namespace tail $_cmd] - - - #obsolete? - ##set IFID0 [lindex $map 1 0 end] - #set IFID0 [lindex [dict get $MAP interfaces level0] end] - ##set IFID1 [lindex $map 1 1 end] - #set IFID1 [lindex [dict get $MAP interfaces level1] end] - - - if {![string match "::*" $clone]} { - if {[set ns [uplevel 1 {namespace current}]] eq "::"} { - set clone ::$clone - } else { - set clone ${ns}::$clone - } - } - - - set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] - set _clone [string map {::> ::} $clone] - - - set cTail [namespace tail $_clone] - - set ns [namespace qualifiers $clone] - if {$ns eq ""} { - set ns "::" - } - - namespace eval $ns {} - - - #if {![llength [info commands $clone]]} {} - if {[namespace which $clone] eq ""} { - set clonemapdata [::p::internals::new_object $clone] - } else { - #overlay/mixin case - target/clone already exists - #set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1] - set clonemapdata [$clone --] - } - set clone_ID [lindex [dict get $clonemapdata invocantdata] 0] - - upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP - - - #copy patterndata element of MAP straight across - dict set CLONEMAP patterndata [dict get $MAP patterndata] - set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata] - lset CLONE_INVOCANTDATA 2 $parent_defaultmethod - dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA - lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone - - #update the clone's _ID_ - interp alias {} $clone_alias {} ;#first we must delete it - interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}] - - #! object_command was initially created as the renamed alias - so we have to do it again - rename $clone_alias $clone - trace add command $clone rename [list $clone .. Rename] - - - - - #obsolete? - #upvar ::p::${clone_ID}:: clone_INFO - #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. - #upvar ::p::${OID}:: INFO - - - array set clone_INFO [array get INFO] - - array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' - - - #!review! - #if {![catch {set itemCmd $IFACE(m-1,name,item)}]} { - #puts "***************" - #puts "clone" - #parray IFINFO - #puts "***************" - #} - - #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern - - - #clone's interface maps must be a superset of original's - foreach lev {0 1} { - #set parent_ifaces [lindex $map 1 $lev] - set parent_ifaces [dict get $MAP interfaces level$lev] - - #set existing_ifaces [lindex $CLONEMAP 1 $lev] - set existing_ifaces [dict get $CLONEMAP interfaces level$lev] - - set added_ifaces_$lev [list] - foreach ifid $parent_ifaces { - if {$ifid ni $existing_ifaces} { - - #interface must not remain extensible after cloning. - if {[set ::p::${ifid}::_iface::o_open]} { - ::p::predator::compile_interface $ifid $_ID_ - set ::p::${ifid}::_iface::o_open 0 - } - - - - lappend added_ifaces_$lev $ifid - #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. - set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone - } - } - set extracted_sub_dict [dict get $CLONEMAP interfaces] - dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]] - dict set CLONEMAP interfaces $extracted_sub_dict - #lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]] - } - - #interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE) - - - #foreach *added* level0 interface.. - foreach ifid $added_ifaces_0 { - namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown - - - dict for {prop pdef} $o_properties { - #lassign $pdef prop default - if {[dict exists $pdef default]} { - set varspace [dict get $pdef varspace] - if {$varspace eq ""} { - set ns ::p::${clone_ID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${clone_ID}::$varspace - } - } - - if {![info exists ${ns}::o_$prop]} { - #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) - set ${ns}::o_$prop [dict get $pdef default] - } - } - - #! May be replaced by method of same name - if {[namespace which ::p::${clone_ID}::$prop] eq ""} { - interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop - } - interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop - interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop - } - - #variables - dict for {vname vdef} $o_variables { - if {[dict exists $vdef default]} { - set varspace [dict get $vdef varspace] - if {$varspace eq ""} { - set ns ::p::${clone_ID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${clone_ID}::$varspace - } - } - if {![info exists ${ns}::$vname]} { - set ::p::${clone_ID}::$vname [dict get $vdef default] - } - } - } - - - #update the clone object's base interface to reflect the new methods. - #upvar 0 ::p::${ifid}:: IFACE - #set methods [list] - #foreach {key mname} [array get IFACE m-1,name,*] { - # set method [lindex [split $key ,] end] - # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP - # lappend methods $method - #} - #namespace eval ::p::${clone_ID} [list namespace export {*}$methods] - - - foreach method [dict keys $o_methods] { - - set arglist [dict get $o_methods $method arglist] - set argvals "" - foreach argspec $arglist { - if {[llength $argspec] == 2} { - set a [lindex $argspec 0] - } else { - set a $argspec - } - - if {$a eq "args"} { - append argvals " \{*\}\$args" - } else { - append argvals " \$$a" - } - } - set argvals [string trimleft $argvals] - #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method - - - #this proc directly on the object is not *just* a forwarding proc - # - it provides a context in which the 'uplevel 1' from the running interface proc runs - #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) - - #proc calls the method in the interface - which is an interp alias to the head of the implementation chain - proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst { - ::p::${ifid}::_iface::$method \$_ID_ $argvals - }] - - } - #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods] - - - if {[info exists o_unknown]} { - #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown - interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown - interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown - - #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown] - #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown] - - } - - - #2021 - #Consider >parent with constructor that sets height - #.eg >parent .. Constructor height { - # set o_height $height - #} - #>parent .. Create >child 5 - # - >child has height 5 - # now when we peform a clone operation - it is the >parent's constructor that will run. - # A clone will get default property and var values - but not other variable values unless the constructor sets them. - #>child .. Clone >fakesibling 6 - # - >sibling has height 6 - # Consider if >child had it's own constructor created with .. Construct prior to the clone operation. - # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead. - # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining... - # when we now do >sibling .. Create >grandchild - # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild - # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.) - # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild - #(though other arguments can be manually passed) - # #!review - does this make sense? What if we add - # - #constructor for each interface called after properties initialised. - #run each interface's constructor against child object, using the args passed into this clone method. - if {[llength [set constructordef [set o_constructor]]]} { - #error - puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID" - ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args - - } - - } - - - return $clone - -} - - - -interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?) -dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}} -proc ::p::-1::Constructor {_ID_ arglist body} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - #lassign [lindex $invocant 0 ] OID alias itemCmd cmd - - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. - set iface ::p::ifaces::>$iid_top - - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - #set iid_top [::p::get_new_object_id] - - #the >interface constructor takes a list of IDs for o_usedby - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] - - #::p::predator::remap $invocant - } - set IID $iid_top - - namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces - - - # examine the existing command-chain - set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] - set headid [expr {$maxversion + 1}] - set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 - - set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] - - #set varspaces [::pattern::varspace_list] - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] - set body $varDecls\n[dict get $processed body] - #puts stderr "\t runtime_vardecls in Constructor $varDecls" - } - - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - #puts stderr ---- - #puts stderr $body - #puts stderr ---- - - proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body - interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid - - - - set o_constructor [list $arglist $body] - set o_open 1 - - return -} - - - -dict set ::p::-1::_iface::o_methods UsedBy {arglist {}} -proc ::p::-1::UsedBy {_ID_} { - return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby] -} - - -dict set ::p::-1::_iface::o_methods Ready {arglist {}} -proc ::p::-1::Ready {_ID_} { - return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}] -} - - - -dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}} - -#'force' 1 indicates object command & variable will also be removed. -#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var. -#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4) -# -proc ::p::-1::Destroy {_ID_ {force 1}} { - #puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]" - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - - if {$OID eq "null"} { - puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" - return - } - - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - - #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout - - #explicit Destroy - remove traces - #puts ">>TRACES: [trace info variable $cmd]" - #foreach tinfo [trace info variable $cmd] { - # trace remove variable $cmd {*}$tinfo - #} - #foreach tinfo [trace info command $cmd] { - # trace remove command $cmd {*}$tinfo - #} - - - set _cmd [string map {::> ::} $cmd] - - #set ifaces [lindex $map 1] - set iface_stacks [dict get $MAP interfaces level0] - #set patterns [lindex $map 2] - set pattern_stacks [dict get $MAP interfaces level1] - - - - set ifaces $iface_stacks - - - set patterns $pattern_stacks - - - #set i 0 - #foreach iflist $ifaces { - # set IFID$i [lindex $iflist 0] - # incr i - #} - - - set IFTOP [lindex $ifaces end] - - set DESTRUCTOR ::p::${IFTOP}::___system___destructor - #may be a proc, or may be an alias - if {[namespace which $DESTRUCTOR] ne ""} { - set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] - - if {[catch {$DESTRUCTOR $temp_ID_} prob]} { - #!todo - ensure correct calling order of interfaces referencing the destructor proc - - - #!todo - emit destructor errors somewhere - logger? - #puts stderr "underlying proc already removed??? ---> $prob" - #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" - #puts stderr $::errorInfo - #puts stderr "---------------------" - } - } - - - #remove ourself from each interfaces list of referencers - #puts stderr "--- $ifaces" - - foreach var {ifaces patterns} { - - foreach i [set $var] { - - if {[string length $i]} { - if {$i == 2} { - #skip the >ifinfo interface which doesn't maintain a usedby list anyway. - continue - } - - if {[catch { - - upvar #0 ::p::${i}::_iface::o_usedby usedby - - array unset usedby i$OID - - - #puts "\n***>>***" - #puts "IFACE: $i usedby: $usedby" - #puts "***>>***\n" - - #remove interface if no more referencers - if {![array size usedby]} { - #puts " **************** DESTROYING unused interface $i *****" - #catch {namespace delete ::p::$i} - - #we happen to know where 'interface' object commands are kept: - - ::p::ifaces::>$i .. Destroy - - } - - } errMsg]} { - #warning - puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" - } - } - - } - - } - - set ns ::p::${OID} - #puts "-- destroying objects below namespace:'$ns'" - ::p::internals::DestroyObjectsBelowNamespace $ns - #puts "--.destroyed objects below '$ns'" - - - #set ns ::p::${OID}::_sub - #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace - #( ::p::OBJECT::$OID ) - #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" - #::p::internals::DestroyObjectsBelowNamespace $ns - - #same for _meta objects (e.g Methods,Properties collections) - #set ns ::p::${OID}::_meta - #::p::internals::DestroyObjectsBelowNamespace $ns - - - - #foreach obj [info commands ${ns}::>*] { - # #Assume it's one of ours, and ask it to die. - # catch {::p::meta::Destroy $obj} - # #catch {$cmd .. Destroy} - #} - #just in case the user created subnamespaces.. kill objects there too. - #foreach sub [namespace children $ns] { - # ::p::internals::DestroyObjectsBelowNamespace $sub - #} - - - #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value! - #use info commands ::p::${OID}::_ref::* to find all references - including variables never set - #remove variable traces on REF vars - #foreach rv [info vars ::p::${OID}::_ref::*] { - # foreach tinfo [trace info variable $rv] { - # #puts "-->removing traces on $rv: $tinfo" - # trace remove variable $rv {*}$tinfo - # } - #} - - #!todo - write tests - #refs create aliases and variables at the same place - #- but variable may not exist if it was never set e.g if it was only used with info exists - foreach rv [info commands ::p::${OID}::_ref::*] { - foreach tinfo [trace info variable $rv] { - #puts "-->removing traces on $rv: $tinfo" - trace remove variable $rv {*}$tinfo - } - } - - - - - - - - #if {[catch {namespace delete $nsMeta} msg]} { - # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " - #} else { - # #puts stderr "------ -- -- -- -- deleted $nsMeta " - #} - - - #!todo - remove - #temp - #catch {interp alias "" ::>$OID ""} - - if {$force} { - #rename $cmd {} - - #removing the alias will remove the command - even if it's been renamed - interp alias {} $alias {} - - #if {[catch {rename $_cmd {} } why]} { - # #!todo - work out why some objects don't have matching command. - # #puts stderr "\t rename $_cmd {} failed" - #} else { - # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" - #} - - } - - set refns ::p::${OID}::_ref - #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" - #puts "- children: [llength [namespace children $refns]]" - #puts "- vars : [llength [info vars ${refns}::*]]" - #puts "- commands: [llength [info commands ${refns}::*]]" - #puts "- procs : [llength [info procs ${refns}::*]]" - #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" - #puts "- matching command: [llength [info commands ${refns}]]" - #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" - - - #foreach v [info vars ${refns}::*] { - # unset $v - #} - #foreach p [info procs ${refns}::*] { - # rename $p {} - #} - #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { - # interp alias {} $a {} - #} - - - #set ts1 [clock seconds] - #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." - #puts "- children: [llength [namespace children $refns]]" - #puts "- vars : [llength [info vars ${refns}::*]]" - - #puts "- commands: [llength [info commands ${refns}::*]]" - #puts "- procs : [llength [info procs ${refns}::*]]" - #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" - #puts "- exact command: [info commands ${refns}]" - - - - - #puts "--delete ::p::${OID}::_ref" - if {[namespace exists ::p::${OID}::_ref]} { - #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. - namespace delete ::p::${OID}::_ref:: - } - set ts2 [clock seconds] - #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" - - - #delete namespace where instance variables reside - #catch {namespace delete ::p::$OID} - namespace delete ::p::$OID - - #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout - return -} - - -interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility - - -dict set ::p::-1::_iface::o_methods Destructor {arglist {args}} -#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction? -#install a Destructor on the invocant's open level1 interface. -proc ::p::-1::Destructor {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - #lassign [lindex $map 0] OID alias itemCmd cmd - - set patterns [dict get $MAP interfaces level1] - - if {[llength $args] > 2} { - error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" - } - - set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - error "NOT TESTED" - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - - #::p::predator::remap $invocant - } - - - set ::p::${IID}::_iface::o_destructor_body [lindex $args end] - - if {[llength $args] > 1} { - #!todo - allow destructor args(?) - set arglist [lindex $args 0] - } else { - set arglist [list] - } - - set ::p::${IID}::_iface::o_destructor_args $arglist - - return -} - - - - - -interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit) - - -dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}} -proc ::p::-1::PatternMethod {_ID_ method arglist body} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. - set iface ::p::ifaces::>$iid_top - - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - set IID $iid_top - - - namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces - - - # examine the existing command-chain - set maxversion [::p::predator::method_chainhead $IID $method] - set headid [expr {$maxversion + 1}] - set THISNAME $method.$headid ;#first version will be $method.1 - - set next [::p::predator::next_script $IID $method $THISNAME $_ID_] - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - #puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls" - set body $varDecls\n[dict get $processed body] - #puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls" - } - - - set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist] - - #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] - #puts "\t\t--------------------" - #puts "\n" - #puts $body - #puts "\n" - #puts "\t\t--------------------" - proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body - - - - #pointer from method-name to head of the interface's command-chain - interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME - - - - if {$method in [dict keys $o_methods]} { - #error "patternmethod '$method' already present in interface $IID" - set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)" - if {[string match "*@next@*" $body]} { - append msg "\n EXTRA-WARNING: method contains @next@" - } - - puts stdout $msg - } else { - dict set o_methods $method [list arglist $arglist] - } - - #::p::-1::update_invocant_aliases $_ID_ - return -} - -#MultiMethod -#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants -# e.g1 $obj .. MultiMethod add {these 2} $arglist $body -# e.g2 $obj .. MultiMethod add {these n} $arglist $body -# -# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body -# -# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature. -# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature) -# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces) -# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? -# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed? -# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? -# (and how would we define the call order? - presumably as it appears in the conglomerate) -# (or could that be done with a more general method-wrapping mechanism?) -#...should multimethods use some sort of event mechanism, and/or message-passing system? -# -dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}} -proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { - set invocants [dict get $_ID_ i] - - error "not implemented" -} - -dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} -# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- ) -#we can create a method named "." by using the argprotect operator -- -# e.g >x .. Method -- . {args} $body -#It can then be called like so: >x . . -#This is not guaranteed to work and is not in the test suite -#for now we'll just use a highly unlikely string to indicate no argument was supplied -proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { - set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped - if {$methodname eq $non_argument_magicstring} { - return $default_method - } else { - set extracted_value [dict get $MAP invocantdata] - lset extracted_value 2 $methodname - dict set MAP invocantdata $extracted_value ;#write modified value back - #update the object's command alias to match - interp alias {} $alias {} ;#first we must delete it - interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] - - #! $object_command was initially created as the renamed alias - so we have to do it again - rename $alias $object_command - trace add command $object_command rename [list $object_command .. Rename] - return $methodname - } -} - -dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} -proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { - set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set extracted_patterndata [dict get $MAP patterndata] - set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] - if {$methodname eq $non_argument_magicstring} { - return $pattern_default_method - } else { - dict set extracted_patterndata patterndefaultmethod $methodname - dict set MAP patterndata $extracted_patterndata - return $methodname - } -} - - -dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}} -proc ::p::-1::Method {_ID_ method arglist bodydef args} { - set invocants [dict get $_ID_ i] - - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - set invocant_signature [list] ; - ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. - foreach role [lsort [dict keys $invocants]] { - lappend invocant_signature $role [llength [dict get $invocants $role]] - } - #note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this') - - - - lassign [dict get $MAP invocantdata] OID alias default_method object_command - set interfaces [dict get $MAP interfaces level0] - - - - ################################################################################# - if 0 { - set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface - set prev_open [set ::p::${iid_top}::_iface::o_open] - - set iface ::p::ifaces::>$iid_top - - set f_new 0 - if {![string length $iid_top]} { - set f_new 1 - } else { - if {[$iface . isClosed]} { - set f_new 1 - } - } - if {$f_new} { - #create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat $interfaces $iid_top] - dict set MAP interfaces $extracted_sub_dict - - } - set IID $iid_top - - } - ################################################################################# - - set IID [::p::predator::get_possibly_new_open_interface $OID] - - #upvar 0 ::p::${IID}:: IFACE - - namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces - - - #Interface proc - # examine the existing command-chain - set maxversion [::p::predator::method_chainhead $IID $method] - set headid [expr {$maxversion + 1}] - set THISNAME $method.$headid ;#first version will be $method.1 - - if {$method ni [dict keys $o_methods]} { - dict set o_methods $method [list arglist $arglist] - } - - #next_script will call to lower interface in iStack if we are $method.1 - set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_ - #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<" - - - #implement - #----------------------------------- - set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - set varDecls "" - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls\n[dict get $processed body] - } - - - set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist] - - - - - - - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - #if {[string length $varDecls]} { - # puts stdout "\t---------------------------------------------------------------" - # puts stdout "\t----- efficiency warning - implicit var declarations used -----" - # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" - # puts stdout "\t[string map [list \n \t\t\n] $body]" - # puts stdout "\t--------------------------" - #} - #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role - # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. - #(as specified by the @ operator during object conglomeration) - #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] - - #puts stdout "\t\t----------------------------" - #puts stdout "$body" - #puts stdout "\t\t----------------------------" - - proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body - - #----------------------------------- - - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME - - - #point to the interface command only. The dispatcher will supply the invocant data - #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method - set argvals "" - foreach argspec $arglist { - if {[llength $argspec] == 2} { - set a [lindex $argspec 0] - } else { - set a $argspec - } - if {$a eq "args"} { - append argvals " \{*\}\$args" - } else { - append argvals " \$$a" - } - } - set argvals [string trimleft $argvals] - #this proc directly on the object is not *just* a forwarding proc - # - it provides a context in which the 'uplevel 1' from the running interface proc runs - #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) - - #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain - - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { - ::p::${IID}::_iface::$method \$_ID_ $argvals - }] - - - if 0 { - if {[llength $argvals]} { - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { - apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ - }] - } else { - - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { - apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ - }] - - } - } - - - #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { - # ::p::${IID}::_iface::$method \$_ID_ $argvals - #}] - - #todo - for o_varspaces - #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method - #- this should work correctly with the 'uplevel 1' procs in the interfaces - - - if {[string length $o_varspace]} { - if {[string match "::*" $o_varspace]} { - namespace eval $o_varspace {} - } else { - namespace eval ::p::${OID}::$o_varspace {} - } - } - - - #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. - set colMethods ::p::${OID}::_meta::>colMethods - - if {[namespace which $colMethods] ne ""} { - if {![$colMethods . hasKey $method]} { - $colMethods . add [::p::internals::predator $_ID_ . $method .] $method - } - } - - #::p::-1::update_invocant_aliases $_ID_ - return - #::>pattern .. Create [::>pattern .. Namespace]::>method_??? - #return $method_object -} - - -dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}} -proc ::p::-1::V {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - - - set vlist [list] - foreach IID $ifaces { - dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { - if {[string match $glob $vname]} { - lappend vlist $vname - } - } - } - - - return $vlist -} - -#experiment from http://wiki.tcl.tk/4884 -proc p::predator::pipeline {args} { - set lambda {return -level 0} - foreach arg $args { - set lambda [list apply [dict get { - toupper {{lambda input} {string toupper [{*}$lambda $input]}} - tolower {{lambda input} {string tolower [{*}$lambda $input]}} - totitle {{lambda input} {string totitle [{*}$lambda $input]}} - prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}} - suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}} - } [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]] - } - return $lambda -} - -proc ::p::predator::get_apply_arg_0_oid {} { - set apply_args [lrange [info level 0] 2 end] - puts stderr ">>>>> apply_args:'$apply_args'<<<<" - set invocant [lindex $apply_args 0] - return [lindex [dict get $invocant i this] 0 0] -} -proc ::p::predator::get_oid {} { - #puts stderr "---->> [info level 1] <<-----" - set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 - tailcall lindex [dict get $_ID_ i this] 0 0 -} - -#todo - make sure this is called for all script installations - e.g propertyread etc etc -#Add tests to check code runs in correct namespace -#review - how does 'Varspace' command affect this? -proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} { - #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) - set arglist_apply "" - append arglist_apply "\$_ID_ " - foreach a $arglist { - if {$a eq "args"} { - append arglist_apply "{*}\$args" - } else { - append arglist_apply "\$[lindex $a 0] " - } - } - #!todo - allow fully qualified varspaces - if {[string length $varspace]} { - if {[string match ::* $varspace]} { - return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply" - } else { - #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n" - return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply" - } - } else { - #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" - #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" - - set script "tailcall apply \[list \{_ID_" - - if {[llength $arglist]} { - append script " $arglist" - } - append script "\} \{" - append script $body - append script "\} ::p::@OID@\] " - append script $arglist_apply - #puts stderr "\n88888888888888888888888888\n\t$script\n" - #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" - #return $script - - - #----------------------------------------------------------------------------- - # 2018 candidates - # - #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled - #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled - - - #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) - #faster though. - #return "uplevel 1 \{$body\}" - return "uplevel 1 [list $body]" - #----------------------------------------------------------------------------- - - - - - #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" - #return "uplevel 1 \{$script\}" - - #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail - #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail - - - - #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong - - #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns - - - #experiment with different dispatch mechanism (interp alias with 'namespace inscope') - #----------- - #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" - - - #return "uplevel 1 \{$body\}" ;#do nothing - - #---------- - - #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) - - #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body - - #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker - - #return "tailcall " - - - } -} - - -#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies. -#expand 'var' statements inline in method bodies -#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements. -# -#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces -#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches! -# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements. -#Think of var & varspace statments as a form of compile-time 'macro' -# -#caters for 2-element lists as arguments to var statement to allow 'aliasing' -#e.g var o_thing {o_data mydata} -# this will upvar o_thing as o_thing & o_data as mydata -# -proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { - set body {} - - #keep count of any explicit var statments per varspace in 'numDeclared' array - # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements. - - #default varspace is "" - #varspace should only have leading :: if it is an absolute namespace path. - - - foreach ln [split $rawbody \n] { - set trimline [string trim $ln] - - if {$trimline eq "var"} { - #plain var statement alone indicates we don't have any explicit declarations in this branch - # and we don't want implicit declarations for the current varspace either. - #!todo - implement test - - incr numDeclared($varspace) - - #may be further var statements e.g - in other code branches - #return [list body $rawbody varspaces_with_explicit_vars 1] - } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { - - #append body " upvar #0 " - #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " - #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " - - if {$varspace eq ""} { - append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " - } else { - if {[string match "::*" $varspace]} { - append body " namespace upvar $varspace " - } else { - append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " - } - } - - #any whitespace before or betw var names doesn't matter - about to use as list. - foreach varspec [string range $trimline 4 end] { - lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. - ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " - #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " - - append body "$var $alias " - - } - append body \n - - incr numDeclared($varspace) - } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { - #2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? - #it is assumed there is a single word following the 'varspace' keyword. - set varspace [string trim [string range $trimline 9 end]] - - if {$varspace in [list {{}} {""}]} { - set varspace "" - } - if {[string length $varspace]} { - #set varspace ::${varspace}:: - #no need to initialize numDeclared($varspace) incr will work anyway. - #if {![info exists numDeclared($varspace)]} { - # set numDeclared($varspace) 0 - #} - - if {[string match "::*" $varspace]} { - append body "namespace eval $varspace {} \n" - } else { - append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n" - } - - #puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} " - #append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n" - #append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n" - - #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n" - } - #!review - why? why do we need the magic 'default' name instead of just using the empty string? - #if varspace argument was empty string - leave it alone - } else { - append body $ln\n - } - } - - - - set varspaces [array names numDeclared] - return [list body $body varspaces_with_explicit_vars $varspaces] -} - - - - -#Interface Variables -dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} -proc ::p::-1::IV {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - - #!todo - test - #return [dict keys ::p::${OID}::_iface::o_variables $glob] - - set members [list] - foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { - if {[string match $glob $vname]} { - lappend members $vname - } - } - return $members -} - - -dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}} -proc ::p::-1::Methods {_ID_ {idx ""}} { - set invocants [dict get $_ID_ i] - set this_invocant [lindex [dict get $invocants this] 0] - lassign $this_invocant OID _etc - #set map [dict get $this_info map] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - set col ::p::${OID}::_meta::>colMethods - - if {[namespace which $col] eq ""} { - patternlib::>collection .. Create $col - foreach IID $ifaces { - foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { - if {![$col . hasIndex $m]} { - #todo - create some sort of lazy-evaluating method object? - #set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist] - $col . add [::p::internals::predator $_ID_ . $m .] $m - } - } - } - } - - if {[string length $idx]} { - return [$col . item $idx] - } else { - return $col - } -} - -dict set ::p::-1::_iface::o_methods M {arglist {}} -proc ::p::-1::M {_ID_} { - set invocants [dict get $_ID_ i] - set this_invocant [lindex [dict get $invocants this] 0] - lassign $this_invocant OID _etc - #set map [dict get $this_info map] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - set members [list] - foreach IID $ifaces { - foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { - lappend members $m - } - } - return $members -} - - -#review -#Interface Methods -dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}} -proc ::p::-1::IM {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - set this_invocant [lindex [dict get $invocants this] 0] - lassign $this_invocant OID _etc - #set map [dict get $this_info map] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] - -} - - - -dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}} -proc ::p::-1::InterfaceStacks {_ID_} { - upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP - return [dict get $MAP interfaces level0] -} - - -dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}} -proc ::p::-1::PatternStacks {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - return [dict get $MAP interfaces level1] -} - - -#!todo fix. need to account for references which were never set to a value -dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}} -proc ::p::-1::DeletePropertyReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - set cleared_references [list] - set refvars [info vars ::p::${OID}::_ref::*] - #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. - foreach rv $refvars { - foreach tinfo [trace info variable $rv] { - set ops {}; set cmd {} - lassign $tinfo ops cmd - trace remove variable $rv $ops $cmd - } - unset $rv - lappend cleared_references $rv - } - - - return [list deleted_property_references $cleared_references] -} - -dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}} -proc ::p::-1::DeleteMethodReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - set cleared_references [list] - - set iflist [dict get $MAP interfaces level0] - set iflist_reverse [lreferse $iflist] - #set iflist [dict get $MAP interfaces level0] - - - set refcommands [info commands ::p::${OID}::_ref::*] - foreach c $refcommands { - set reftail [namespace tail $c] - set field [lindex [split $c +] 0] - set field_is_a_method 0 - foreach IFID $iflist_reverse { - if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { - set field_is_a_method 1 - break - } - } - if {$field_is_a_method} { - #what if it's also a property? - interp alias {} $c {} - lappend cleared_references $c - } - } - - - return [list deleted_method_references $cleared_references] -} - - -dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}} -proc ::p::-1::DeleteReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_method this - - set result [dict create] - dict set result {*}[$this .. DeletePropertyReferences] - dict set result {*}[$this .. DeleteMethodReferences] - - return $result -} - -## -#Digest -# -#!todo - review -# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!) -# -#!todo - write tests - check that digest changes when properties of contained objects change value -# -#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method? -# -dict set ::p::-1::_iface::o_methods Digest {arglist {args}} -proc ::p::-1::Digest {_ID_ args} { - set invocants [dict get $_ID_ i] - # md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway. - #set this_invocant [lindex [dict get $invocants this] 0] - #lassign $this_invocant OID _etc - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] _OID alias default_method this - - - set interface_ids [dict get $MAP interfaces level0] - set IFID0 [lindex $interface_ids end] - - set known_flags {-recursive -algorithm -a -indent} - set defaults {-recursive 1 -algorithm md5 -indent ""} - if {[dict exists $args -a] && ![dict exists $args -algorithm]} { - dict set args -algorithm [dict get $args -a] - } - - set opts [dict merge $defaults $args] - foreach key [dict keys $opts] { - if {$key ni $known_flags} { - error "unknown option $key. Expected only: $known_flags" - } - } - - - set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256} - if {[dict get $opts -algorithm] ni $known_algos} { - error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos" - } - set algo [string tolower [dict get $opts -algorithm]] - - # append comma for each var so that all changes in adjacent vars detectable. - # i.e set x 34; set y 5 - # must be distinguishable from: - # set x 3; set y 45 - - if {[dict get $opts -indent] ne ""} { - set state "" - set indent "[dict get $opts -indent]" - } else { - set state "---\n" - set indent " " - } - append state "${indent}object_command: $this\n" - set indent "${indent} " - - #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state. - append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state. - - - - - #!todo - recurse into 'varspaces' - set varspaces_found [list] - append state "${indent}interfaces:\n" - foreach IID $interface_ids { - append state "${indent} - interface: $IID\n" - namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces - append state "${indent} varspaces:\n" - foreach vs $local_o_varspaces { - if {$vs ni $varspaces_found} { - lappend varspaces_found $vs - append state "${indent} - varspace: $vs\n" - } - } - } - - append state "${indent}vars:\n" - foreach var [info vars ::p::${OID}::*] { - append state "${indent} - [namespace tail $var] : \"" - if {[catch {append state "[set $var]"}]} { - append state "[array get $var]" - } - append state "\"\n" - } - - if {[dict get $opts -recursive]} { - append state "${indent}sub-objects:\n" - set subargs $args - dict set subargs -indent "$indent " - foreach obj [info commands ::p::${OID}::>*] { - append state "[$obj .. Digest {*}$subargs]\n" - } - - append state "${indent}sub-namespaces:\n" - set subargs $args - dict set subargs -indent "$indent " - foreach ns [namespace children ::p::${OID}] { - append state "${indent} - namespace: $ns\n" - foreach obj [info commands ${ns}::>*] { - append state "[$obj .. Digest {*}$subargs]\n" - } - } - } - - - if {$algo in {"" raw none}} { - return $state - } else { - if {$algo eq "md5"} { - package require md5 - return [::md5::md5 -hex $state] - } elseif {$algo eq "sha256"} { - package require sha256 - return [::sha2::sha256 -hex $state] - } elseif {$algo eq "blowfish"} { - package require patterncipher - patterncipher::>blowfish .. Create >b1 - set [>b1 . key .] 12341234 - >b1 . encrypt $state -final 1 - set result [>b1 . ciphertext] - >b1 .. Destroy - - } elseif {$algo eq "blowfish-binary"} { - - } else { - error "can't get here" - } - - } -} - - -dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}} -proc ::p::-1::Variable {_ID_ varname args} { - set invocants [dict get $_ID_ i] - - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - #this interface itself is always a co-invocant - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set interfaces [dict get $MAP interfaces level0] - - #set existing_IID [lindex $map 1 0 end] - set existing_IID [lindex $interfaces end] - - set prev_openstate [set ::p::${existing_IID}::_iface::o_open] - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #IID changed - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - - #update original object command - set ::p::${IID}::_iface::o_open 0 - } else { - set ::p::${IID}::_iface::o_open $prev_openstate - } - - set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface) - - if {[llength $args]} { - #!assume var not already present on interface - it is an error to define twice (?) - #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] - dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] - - - #Implement if there is a default - #!todo - correct behaviour when overlaying on existing object with existing var of this name? - #if {[string length $varspace]} { - # set ::p::${OID}::${varspace}::$varname [lindex $args 0] - #} else { - set ::p::${OID}::$varname [lindex $args 0] - #} - } else { - #lappend ::p::${IID}::_iface::o_variables [list $varname] - dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] - } - - #varspace '_iface' - - return -} - - -#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility - -dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}} -proc ::p::-1::PatternVariable {_ID_ varname args} { - set invocants [dict get $_ID_ i] - - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - ##this interface itself is always a co-invocant - #lassign [lindex $invocant 0 ] OID alias itemCmd cmd - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. - set iface ::p::ifaces::>$iid_top - - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] - } - set IID $iid_top - - set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. - - - if {[llength $args]} { - #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] - dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] - } else { - dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] - } - - return -} - -dict set ::p::-1::_iface::o_methods Varspaces {arglist args} -proc ::p::-1::Varspaces {_ID_ args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - if {![llength $args]} { - #query - set iid_top [lindex [dict get $MAP interfaces level0] end] - set iface ::p::ifaces::>$iid_top - if {![string length $iid_top]} { - error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " - } elseif {[$iface . isClosed]} { - error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " - } - return [set ::p::${iid_top}::_iface::o_varspaces] - } - set IID [::p::predator::get_possibly_new_open_interface $OID] - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces - - set varspaces $args - foreach vs $varspaces { - if {[string length $vs] && ($vs ni $o_varspaces)} { - if {[string match ::* $vs} { - namespace eval $vs {} - } else { - namespace eval ::p::${OID}::$vs {} - } - lappend o_varspaces $vs - } - } - return $o_varspaces -} - -#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface -dict set ::p::-1::_iface::o_methods Varspace {arglist args} -# set the default varspace for the interface, so that new methods/properties refer to it. -# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. -proc ::p::-1::Varspace {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - if {![llength $args]} { - #query - set iid_top [lindex [dict get $MAP interfaces level0] end] - set iface ::p::ifaces::>$iid_top - if {![string length $iid_top]} { - error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " - } elseif {[$iface . isClosed]} { - error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " - } - return [set ::p::${iid_top}::_iface::o_varspace] - } - set varspace [lindex $args 0] - - #set interfaces [dict get $MAP interfaces level0] - #set iid_top [lindex $interfaces end] - - set IID [::p::predator::get_possibly_new_open_interface $OID] - - - #namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces - - if {[string length $varspace]} { - #ensure namespace exists !? do after list test? - if {[string match ::* $varspace]} { - namespace eval $varspace {} - } else { - namespace eval ::p::${OID}::$varspace {} - } - if {$varspace ni $o_varspaces} { - lappend o_varspaces $varspace - } - } - set o_varspace $varspace -} - - -proc ::p::predator::get_possibly_new_open_interface {OID} { - #we need to re-upvar MAP rather than using a parameter - as we need to write back to it - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] - set iid_top [lindex $interfaces end] - - - set iface ::p::ifaces::>$iid_top - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - #puts stderr ">>>>creating new interface $iid_top" - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat $interfaces $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - - return $iid_top -} - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}} -# set the default varspace for the interface, so that new methods/properties refer to it. -# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. -proc ::p::-1::PatternVarspace {_ID_ varspace args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] - - set iface ::p::ifaces::>$iid_top - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #no existing pattern - create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - set IID $iid_top - - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces - if {[string length $varspace]} { - if {$varspace ni $o_varspaces} { - lappend o_varspaces $varspace - } - } - #o_varspace is the currently active varspace - set o_varspace $varspace - -} -################################################################################################################################################### - -#get varspace and default from highest interface - return all interface ids which define it -dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}} -proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] - - array set propinfo {} - set found_property_names [list] - #start at the lowest and work up (normal storage order of $interfaces) - foreach iid $interfaces { - set propinfodict [set ::p::${iid}::_iface::o_properties] - set matching_propnames [dict keys $propinfodict $propnamepattern] - foreach propname $matching_propnames { - if {$propname ni $found_property_names} { - lappend found_property_names $propname - } - lappend propinfo($propname,interfaces) $iid - ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one - if {[dict exists $propinfodict $propname default]} { - set propinfo($propname,default) [dict get $propinfodict $propname default] - } - set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] - } - } - - set resultdict [dict create] - foreach propname $found_property_names { - set fields [list varspace $propinfo($propname,varspace)] - if {[array exists propinfo($propname,default)]} { - lappend fields default [set propinfo($propname,default)] - } - lappend fields interfaces $propinfo($propname,interfaces) - dict set resultdict $propname $fields - } - return $resultdict -} - - -dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args} -proc ::p::-1::GetTopPattern {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set interfaces [dict get $MAP interfaces level1] - set iid_top [lindex $interfaces end] - if {![string length $iid_top]} { - lassign [dict get $MAP invocantdata] OID _alias _default_method object_command - error "No installed level1 interfaces (patterns) for object $object_command" - } - return ::p::ifaces::>$iid_top -} - - - -dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args} -proc ::p::-1::GetTopInterface {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set iid_top [lindex [dict get $MAP interfaces level0] end] - if {![string length $iid_top]} { - lassign [dict get $MAP invocantdata] OID _alias _default_method object_command - error "No installed level0 interfaces for object $object_command" - } - return ::p::ifaces::>$iid_top -} - - -dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} -proc ::p::-1::GetExpandableInterface {_ID_ args} { - -} - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods Property {arglist {property args}} -proc ::p::-1::Property {_ID_ property args} { - #puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args" - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - if {[llength $args] > 1} { - error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)" - } - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set interfaces [dict get $MAP interfaces level0] - set iid_top [lindex $interfaces end] - - set prev_openstate [set ::p::${iid_top}::_iface::o_open] - - set iface ::p::ifaces::>$iid_top - - - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat $interfaces $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - set IID $iid_top - - - namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace - - - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 - - - if {$headid == 1} { - #implementation - #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property - - #if {$o_varspace eq ""} { - # set ns ::p::${OID} - #} else { - # if {[string match "::*" $o_varspace]} { - # set ns $o_varspace - # } else { - # set ns ::p::${OID}::$o_varspace - # } - #} - #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]] - - proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]] - - - #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property - proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] - - - #chainhead pointers - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 - interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 - - - } - - if {($property ni [dict keys $o_methods])} { - interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property - } - - - - #installation on object - - #namespace eval ::p::${OID} [list namespace export $property] - - - - #obsolete? - #if {$property ni [P $_ID_]} { - #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces - #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant - #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant - #} - - #link main (GET)/(SET) to this interface - interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property - interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property - - #Only install property if no method of same name already installed here. - #(Method takes precedence over property because property always accessible via 'set' reference) - #convenience pointer to chainhead pointer. - if {$property ni [M $_ID_]} { - interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property - } else { - #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed - - - } - - - set varspace [set ::p::${IID}::_iface::o_varspace] - - - - #Install the matching Variable - #!todo - which should take preference if Variable also given a default? - #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { - # set o_variables [lreplace $o_variables $posn $posn o_$property] - #} else { - # lappend o_variables [list o_$property] - #} - dict set o_variables o_$property [list varspace $varspace] - - - - - if {[llength $args]} { - #should store default once only! - #set IFINFO(v,default,o_$property) $default - - set default [lindex $args end] - - dict set o_properties $property [list default $default varspace $varspace] - - #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { - # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] - #} else { - # lappend o_properties [list $property $default] - #} - - if {$varspace eq ""} { - set ns ::p::${OID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${OID}::$o_varspace - } - } - - set ${ns}::o_$property $default - #set ::p::${OID}::o_$property $default - } else { - - #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { - # set o_properties [lreplace $o_properties $posn $posn [list $property]] - #} else { - # lappend o_properties [list $property] - #} - dict set o_properties $property [list varspace $varspace] - - - #variable ::p::${OID}::o_$property - } - - - - - - #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. - #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) - #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} - - set colProperties ::p::${OID}::_meta::>colProperties - if {[namespace which $colProperties] ne ""} { - if {![$colProperties . hasKey $property]} { - $colProperties . add [::p::internals::predator $_ID_ . $property .] $property - } - } - - return -} -################################################################################################################################################### - - - -################################################################################################################################################### - -################################################################################################################################################### -interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility -dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}} -proc ::p::-1::PatternProperty {_ID_ property args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] - - set iface ::p::ifaces::>$iid_top - - if {(![string length $iid_top]) || ([$iface . isClosed])} { - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] - } - set IID $iid_top - - namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace - - - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 - - - - if {$headid == 1} { - #implementation - #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property - proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]] - #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property - proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] - - - #chainhead pointers - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 - interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 - - } - - if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} { - interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property - } - - set varspace [set ::p::${IID}::_iface::o_varspace] - - #Install the matching Variable - #!todo - which should take preference if Variable also given a default? - #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { - # set o_variables [lreplace $o_variables $posn $posn o_$property] - #} else { - # lappend o_variables [list o_$property] - #} - dict set o_variables o_$property [list varspace $varspace] - - set argc [llength $args] - - if {$argc} { - if {$argc == 1} { - set default [lindex $args 0] - dict set o_properties $property [list default $default varspace $varspace] - } else { - #if more than one arg - treat as a dict of options. - if {[dict exists $args -default]} { - set default [dict get $args -default] - dict set o_properties $property [list default $default varspace $varspace] - } else { - #no default value - dict set o_properties $property [list varspace $varspace] - } - } - #! only set default for property... not underlying variable. - #lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]] - } else { - dict set o_properties $property [list varspace $varspace] - } - return -} -################################################################################################################################################### - - - - - - - - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}} -proc ::p::-1::PatternPropertyRead {_ID_ property args} { - set invocants [dict get $_ID_ i] - - set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' - set OID [lindex $this_invocant 0] - #set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias defaut_command cmd - - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] - - set idxlist [::list] - if {[llength $args] == 1} { - set body [lindex $args 0] - } elseif {[llength $args] == 2} { - lassign $args idxlist body - } else { - error "wrong # args: should be \"property body\" or \"property idxlist body\"" - } - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] - if {$headid == 1} { - set headid 2 ;#reserve 1 for the getprop of the underlying property - } - - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 - set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ - - - #implement - #----------------------------------- - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - - #implementation - if {![llength $idxlist]} { - proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body - } else { - #what are we trying to achieve here? .. - proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body - } - - - #----------------------------------- - - - #adjust chain-head pointer to point to new head. - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid - - return -} -################################################################################################################################################### - - - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}} -proc ::p::-1::PropertyRead {_ID_ property args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead) - lassign [dict get $MAP invocantdata] OID alias default_command cmd - - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] - - - set idxlist [::list] - if {[llength $args] == 1} { - set body [lindex $args 0] - } elseif {[llength $args] == 2} { - lassign $args idxlist body - } else { - error "wrong # args: should be \"property body\" or \"property idxlist body\"" - } - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - - set ::p::${IID}::_iface::o_open 0 - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - - #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd] - - - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] - if {$headid == 1} { - set headid 2 - } - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself) - - set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] - - #implement - #----------------------------------- - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body - - #----------------------------------- - - - - #pointer from prop-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid - - - interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name. - if {$property ni [M $_ID_]} { - interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property - } -} -################################################################################################################################################### - - - - - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}} -proc ::p::-1::PropertyWrite {_ID_ property argname body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd - - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. - - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - set ::p::${IID}::_iface::o_open 0 - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - - #pw short for propertywrite - #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] - array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] - - - set maxversion [::p::predator::method_chainhead $IID (SET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (SET)$property.$headid - - set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] - - #implement - #----------------------------------- - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - - proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body - - #----------------------------------- - - - - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid -} -################################################################################################################################################### - - - - - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}} -proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd - - - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set existing_ifaces [lindex $map 1 1] - set posn [lsearch $existing_ifaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] - - #set ::p::${IID}::_iface::o_open 0 - } else { - } - - #pw short for propertywrite - array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] - - - - - return - -} -################################################################################################################################################### - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}} -proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd - - - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. - - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers - #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers - dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] - - set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (UNSET)$property.$headid - - set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] - - #note $arraykeypattern actually contains the name of the argument - if {[string trim $arraykeypattern] eq ""} { - set arraykeypattern _dontcare_ ;# - } - proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body - - #----------------------------------- - - - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid - -} -################################################################################################################################################### - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}} -proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #set ::p::${IID}::_iface::o_open 0 - } - - - upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers - dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] - - return -} -################################################################################################################################################### - - - -#lappend ::p::-1::_iface::o_methods Implements -#!todo - some way to force overriding of any abstract (empty) methods from the source object -#e.g leave interface open and raise an error when closing it if there are unoverridden methods? - - - - - -#implementation reuse - sugar for >object .. Clone >target -dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}} -proc ::p::-1::Extends {_ID_ pattern} { - if {!([string range [namespace tail $pattern] 0 0] eq ">")} { - error "'Extends' expected a pattern object" - } - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd object_command - - - tailcall $pattern .. Clone $object_command - -} -#implementation reuse - sugar for >pattern .. Create >target -dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}} -proc ::p::-1::PatternExtends {_ID_ pattern} { - if {!([string range [namespace tail $pattern] 0 0] eq ">")} { - error "'PatternExtends' expected a pattern object" - } - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd object_command - - - tailcall $pattern .. Create $object_command -} - - -dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}} -proc ::p::-1::Extend {_ID_ {idx ""}} { - puts stderr "Extend is DEPRECATED - use Expand instead" - tailcall ::p::-1::Expand $_ID_ $idx -} - -#set the topmost interface on the iStack to be 'open' -dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}} -proc ::p::-1::Expand {_ID_ {idx ""}} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set iid_top [lindex $interfaces end] - set iface ::p::ifaces::>$iid_top - - if {![string length $iid_top]} { - #no existing interface - create a new one - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [list $iid_top] - dict set MAP interfaces $extracted_sub_dict ;#write new interface into map - $iface . open - return $iid_top - } else { - if {[$iface . isOpen]} { - #already open.. - #assume ready to expand.. shared or not! - return $iid_top - } - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - if {[$iface . refCount] > 1} { - if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} { - #!warning! not exercised by test suites! - - #remove ourself from the usedby list of the previous interface - array unset ::p::${iid_top}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - #remove existing interface & add - set posn [lsearch $interfaces $iid_top] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - - set iid_top $IID - set iface ::p::ifaces::>$iid_top - } - } - } - - $iface . open - return $iid_top -} - -dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}} -proc ::p::-1::PatternExtend {_ID_ {idx ""}} { - puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead" - tailcall ::p::-1::PatternExpand $_ID_ $idx -} - - - -#set the topmost interface on the pStack to be 'open' if it's not shared -# if shared - 'copylink' to new interface before opening for extension -dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}} -proc ::p::-1::PatternExpand {_ID_ {idx ""}} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - #puts stderr "no tests written for PatternExpand " - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces - set iid_top [lindex $ifaces end] - set iface ::p::ifaces::>$iid_top - - if {![string length $iid_top]} { - #no existing interface - create a new one - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [list $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [list $iid_top] - $iface . open - return $iid_top - } else { - if {[$iface . isOpen]} { - #already open.. - #assume ready to expand.. shared or not! - return $iid_top - } - - if {[$iface . refCount] > 1} { - if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} { - #!WARNING! not exercised by test suite! - #remove ourself from the usedby list of the previous interface - array unset ::p::${iid_top}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $ifaces $iid_top] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID] - - set iid_top $IID - set iface ::p::ifaces::>$iid_top - } - } - } - - $iface . open - return $iid_top -} - - - - - -dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}} -proc ::p::-1::Properties {_ID_ {idx ""}} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - set col ::p::${OID}::_meta::>colProperties - - if {[namespace which $col] eq ""} { - patternlib::>collection .. Create $col - foreach IID $ifaces { - dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] { - if {![$col . hasIndex $prop]} { - $col . add [::p::internals::predator $_ID_ . $prop .] $prop - } - } - } - } - - if {[string length $idx]} { - return [$col . item $idx] - } else { - return $col - } -} - -dict set ::p::-1::_iface::o_methods P {arglist {}} -proc ::p::-1::P {_ID_} { - set invocants [dict get $_ID_ i] - set this_invocant [lindex [dict get $invocants this] 0] - lassign $this_invocant OID _etc - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - set members [list] - foreach IID $interfaces { - foreach prop [dict keys [set ::p::${IID}::_iface::o_properties]] { - lappend members $prop - } - } - return [lsort $members] - -} -#Interface Properties -dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}} -proc ::p::-1::IP {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set members [list] - - foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { - if {[string match $glob [lindex $m 0]]} { - lappend members [lindex $m 0] - } - } - return $members -} - - -#used by rename.test - theoretically should be on a separate interface! -dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}} -proc ::p::-1::CheckInvocants {_ID_ args} { - #check all invocants in the _ID_ are consistent with data stored in their MAP variable - set status "ok" ;#default to optimistic assumption - set problems [list] - - set invocant_dict [dict get $_ID_ i] - set invocant_roles [dict keys $invocant_dict] - - foreach role $invocant_roles { - set invocant_list [dict get $invocant_dict $role] - foreach aliased_invocantdata $invocant_list { - set OID [lindex $aliased_invocantdata 0] - set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] - #we use lrange to make sure the lists are in canonical form - if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { - set status "not-ok" - lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] - } - } - - } - - - set result [dict create] - dict set result status $status - dict set result problems $problems - - return $result -} - - -#get or set t -dict set ::p::-1::_iface::o_methods Namespace {arglist {args}} -proc ::p::-1::Namespace {_ID_ args} { - #set invocants [dict get $_ID_ i] - #set this_invocant [lindex [dict get $invocants this] 0] - #lassign $this_invocant OID this_info - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set IID [lindex [dict get $MAP interfaces level0] end] - - namespace upvar ::p::${IID}::_iface o_varspace active_varspace - - if {[string length $active_varspace]} { - set ns ::p::${OID}::$active_varspace - } else { - set ns ::p::${OID} - } - - #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object? - # - should .. Namespace be usable at all from outside the object? - - - if {[llength $args]} { - #special case some of the namespace subcommands. - - #delete - if {[string match "d*" [lindex $args 0]]} { - error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object." - } - #upvar,ensemble,which,code,origin,expor,import,forget - if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} { - return [namespace eval $ns [list namespace {*}$args]] - } - #current - if {[string match "cu*" [lindex $args 0]]} { - return $ns - } - - #children,eval,exists,inscope,parent,qualifiers,tail - return [namespace {*}[linsert $args 1 $ns]] - } else { - return $ns - } -} - - - - - - - - - - -dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}} -proc ::p::-1::PatternUnknown {_ID_ args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - #::p::predator::remap $invocant - } - - set handlermethod [lindex $args 0] - - - if {[llength $args]} { - set ::p::${IID}::_iface::o_unknown $handlermethod - return - } else { - set ::p::${IID}::_iface::o_unknown $handlermethod - } - -} - - - -dict set ::p::-1::_iface::o_methods Unknown {arglist {args}} -proc ::p::-1::Unknown {_ID_ args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. - - set prev_open [set ::p::${existing_IID}::_iface::o_open] - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - set ::p::${IID}::_iface::o_open 0 - } else { - set ::p::${IID}::_iface::o_open $prev_open - } - - set handlermethod [lindex $args 0] - - if {[llength $args]} { - set ::p::${IID}::_iface::o_unknown $handlermethod - #set ::p::${IID}::(unknown) $handlermethod - - - #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod - interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod - interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod - - #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod] - #namespace eval ::p::${OID} [list namespace unknown $handlermethod] - - return - } else { - set ::p::${IID}::_iface::o_unknown $handlermethod - } - -} - - -#useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []' -# should also work for non-object results -dict set ::p::-1::_iface::o_methods As {arglist {varname}} -proc ::p::-1::As {_ID_ varname} { - set invocants [dict get $_ID_ i] - #puts stdout "invocants: $invocants" - #!todo - handle multiple invocants with other roles, not just 'this' - - set OID [lindex [dict get $_ID_ i this] 0 0] - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - tailcall set $varname $cmd - } else { - #puts stdout "info level 1 [info level 1]" - set role_members [dict get $_ID_ i this] - if {[llength $role_members] == 1} { - set member [lindex $role_members 0] - lassign $member _OID namespace default_method stackvalue _wrapped - tailcall set $varname $stackvalue - } else { - #multiple invocants - return all results as a list - set resultlist [list] - foreach member $role_members { - lassign $member _OID namespace default_method stackvalue _wrapped - lappend resultlist $stackvalue - } - tailcall set $varname $resultlist - } - } -} - -#!todo - AsFileStream ?? -dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}} -proc ::p::-1::AsFile {_ID_ filename args} { - dict set default -force 0 - dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object - set opts [dict merge $default $args] - set force [dict get $opts -force] - set dumpmethod [dict get $opts -dumpmethod] - - - if {[file pathtype $filename] eq "relative"} { - set filename [pwd]/$filename - } - set filedir [file dirname $filename] - if {![sf::file_writable $filedir]} { - error "(method AsFile) ERROR folder $filedir is not writable" - } - if {[file exists $filename]} { - if {!$force} { - error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite" - } - if {![sf::file_writable $filename]} { - error "(method AsFile) ERROR file $filename is not writable - check permissions" - } - } - set fd [open $filename w] - fconfigure $fd -translation binary - - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $_ID_ i this] 0 0] - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - #tailcall set $varname $cmd - set object_data [$cmd {*}$dumpmethod] - puts -nonewline $fd $object_data - close $fd - return [list status 1 bytes [string length $object_data] filename $filename] - } else { - #puts stdout "info level 1 [info level 1]" - set role_members [dict get $_ID_ i this] - if {[llength $role_members] == 1} { - set member [lindex $role_members 0] - lassign $member _OID namespace default_method stackvalue _wrapped - puts -nonewline $fd $stackvalue - close $fd - #tailcall set $varname $stackvalue - return [list status 1 bytes [string length $stackvalue] filename $filename] - } else { - #multiple invocants - return all results as a list - set resultlist [list] - foreach member $role_members { - lassign $member _OID namespace default_method stackvalue _wrapped - lappend resultlist $stackvalue - } - puts -nonewline $fd $resultset - close $fd - return [list status 1 bytes [string length $resultset] filename $filename] - #tailcall set $varname $resultlist - } - } - -} - - - -dict set ::p::-1::_iface::o_methods Object {arglist {}} -proc ::p::-1::Object {_ID_} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - set result [string map [list ::> ::] $cmd] - if {![catch {info level -1} prev_level]} { - set called_by "(called by: $prev_level)" - } else { - set called_by "(called by: interp?)" - - } - - puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" - puts stdout " (returning $result)" - - return $result -} - -#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname -dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} -proc ::p::-1::MakeAlias {_ID_cmdname } { - set OID [::p::obj_get_this_oid $_ID_] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - error "concept probably won't work - try making dispatcher understand trailing '= cmdname' " -} -dict set ::p::-1::_iface::o_methods ID {arglist {}} -proc ::p::-1::ID {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - return $OID -} - -dict set ::p::-1::_iface::o_methods IFINFO {arglist {}} -proc ::p::-1::IFINFO {_ID_} { - puts stderr "--_ID_: $_ID_--" - set OID [::p::obj_get_this_oid $_ID_] - upvar #0 ::p::${OID}::_meta::map MAP - - puts stderr "-- MAP: $MAP--" - - set interfaces [dict get $MAP interfaces level0] - set IFID [lindex $interfaces 0] - - if {![llength $interfaces]} { - puts stderr "No interfaces present at level 0" - } else { - foreach IFID $interfaces { - set iface ::p::ifaces::>$IFID - puts stderr "$iface : [$iface --]" - puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" - set variables [set ::p::${IFID}::_iface::o_variables] - puts stderr "\tvariables: $variables" - } - } - -} - - - - -dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} -proc ::p::-1::INVOCANTDATA {_ID_} { - #same as a call to: >object .. - return $_ID_ -} - -#obsolete? -dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}} -proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} { - set updated_ID_ $_ID_ - array set updated_roles [list] - - set invocants [dict get $_ID_ i] - set invocant_roles [dict keys $invocants] - foreach role $invocant_roles { - - set role_members [dict get $invocants $role] - foreach member [dict get $invocants $role] { - #each member is a 2-element list consisting of the OID and a dictionary - #each member is a 5-element list - #set OID [lindex $member 0] - #set object_dict [lindex $member 1] - lassign $member OID alias itemcmd cmd wrapped - - set MAP [set ::p::${OID}::_meta::map] - #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} - - if {[dict get $MAP invocantdata] eq $member} - #same - nothing to do - - } else { - package require overtype - puts stderr "---------------------------------------------------------" - puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" - set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] - puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" - puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" - puts stderr "---------------------------------------------------------" - #take _meta::map version - lappend updated_roles($role) [dict get $MAP invocantdata] - } - - } - - #overwrite changed roles only - foreach role [array names updated_roles] { - dict set updated_ID_ i $role [set updated_roles($role)] - } - - return $updated_ID_ -} - - - -dict set ::p::-1::_iface::o_methods INFO {arglist {}} -proc ::p::-1::INFO {_ID_} { - set result "" - append result "_ID_: $_ID_\n" - - set invocants [dict get $_ID_ i] - set invocant_roles [dict keys $invocants] - append result "invocant roles: $invocant_roles\n" - set total_invocants 0 - foreach key $invocant_roles { - incr total_invocants [llength [dict get $invocants $key]] - } - - append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" - foreach key $invocant_roles { - append result "\t-------------------------------\n" - append result "\trole: $key\n" - set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants - append result "\t Raw data for this role: $role_members\n" - append result "\t Number of invocants in this role: [llength $role_members]\n" - foreach member $role_members { - #set OID [lindex [dict get $invocants $key] 0 0] - set OID [lindex $member 0] - append result "\t\tOID: $OID\n" - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - append result "\t\tmap:\n" - foreach key [dict keys $MAP] { - append result "\t\t\t$key\n" - append result "\t\t\t\t [dict get $MAP $key]\n" - append result "\t\t\t----\n" - } - lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped - append result "\t\tNamespace: $namespace\n" - append result "\t\tDefault method: $default_method\n" - append result "\t\tCommand: $cmd\n" - append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n" - append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n" - append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n" - } else { - lassign $member _OID namespace default_method stackvalue _wrapped - append result "\t\t last item on the predator stack is a value not an object" - append result "\t\t Value is: $stackvalue" - - } - } - append result "\n" - append result "\t-------------------------------\n" - } - - - - return $result -} - - - - -dict set ::p::-1::_iface::o_methods Rename {arglist {args}} -proc ::p::-1::Rename {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - if {![llength $args]} { - error "Rename expected \$newname argument" - } - - #Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant? - upvar #0 ::p::${OID}::_meta::map MAP - - - - #puts ">>.>> Rename. _ID_: $_ID_" - - if {[catch { - - if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { - - #appears to be a 'trace command rename' firing - #puts "\t>>>> rename trace fired $MAP $args <<<" - - lassign $args oldcmd newcmd - set extracted_invocantdata [dict get $MAP invocantdata] - lset extracted_invocantdata 3 $newcmd - dict set MAP invocantdata $extracted_invocantdata - - - lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped - - #Write the same info into the _ID_ value of the alias - interp alias {} $alias {} ;#first we must delete it - interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] - - - - #! $object_command was initially created as the renamed alias - so we have to do it again - uplevel 1 [list rename $alias $object_command] - trace add command $object_command rename [list $object_command .. Rename] - - } elseif {[llength $args] == 1} { - #let the rename trace fire and we will be called again to do the remap! - uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] - } else { - error "Rename expected \$newname argument ." - } - - } errM]} { - puts stderr "\t@@@@@@ rename error" - set ruler "\t[string repeat - 80]" - puts stderr $ruler - puts stderr $errM - puts stderr $ruler - - } - - return - - -} - -proc ::p::obj_get_invocants {_ID_} { - return [dict get $_ID_ i] -} -#The invocant role 'this' is special and should always have only one member. -# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX -proc ::p::obj_get_this_oid {_ID_} { - return [lindex [dict get $_ID_ i this] 0 0] -} -proc ::p::obj_get_this_ns {_ID_} { - return [lindex [dict get $_ID_ i this] 0 1] -} - -proc ::p::obj_get_this_cmd {_ID_} { - return [lindex [dict get $_ID_ i this] 0 3] -} -proc ::p::obj_get_this_data {_ID_} { - lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd - #set this_invocant_data {*}[dict get $_ID_ i this] - return [list oid $OID ns $ns cmd $cmd] -} -proc ::p::map {OID varname} { - tailcall upvar #0 ::p::${OID}::_meta::map $varname -} - - - +package require dictutils +package provide metaface [namespace eval metaface { + variable version + set version 1.2.5 +}] + + + + +#example datastructure: +#$_ID_ +#{ +#i +# { +# this +# { +# {16 ::p::16 item ::>x {}} +# } +# role2 +# { +# {17 ::p::17 item ::>y {}} +# {18 ::p::18 item ::>z {}} +# } +# } +#context {} +#} + +#$MAP +#invocantdata {16 ::p::16 item ::>x {}} +#interfaces {level0 +# { +# api0 {stack {123 999}} +# api1 {stack {333}} +# } +# level0_default api0 +# level1 +# { +# } +# level1_default {} +# } +#patterndata {patterndefaultmethod {}} + + +namespace eval ::p::predator {} +#temporary alternative to ::p::internals namespace. +# - place predator functions here until ready to replace internals. + + +namespace eval ::p::snap { + variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks. +} + + + + +# not called directly. Retrieved using 'info body ::p::predator::getprop_template' +#review - why use a proc instead of storing it as a string? +proc ::p::predator::getprop_template {_ID_ args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args]} { + #lassign [lindex $invocant 0] OID alias itemCmd cmd + if {[array exists ${ns}::o_%prop%]} { + #return [set ${ns}::o_%prop%($args)] + if {[llength $args] == 1} { + return [set ::p::${OID}::o_%prop%([lindex $args 0])] + } else { + return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]] + } + } else { + set val [set ${ns}::o_%prop%] + + set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] + if {$rType eq "object"} { + #return [$val . item {*}$args] + return [$val {*}$args] + } else { + #treat as list? + return [lindex $val $args] + } + } + } else { + return [set ${ns}::o_%prop%] + } +} + + +proc ::p::predator::getprop_template_immediate {_ID_ args} { + if {[llength $args]} { + if {[array exists %ns%::o_%prop%]} { + return [set %ns%::o_%prop%($args)] + } else { + set val [set %ns%::o_%prop%] + set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] + if {$rType eq "object"} { + #return [$val . item {*}$args] + #don't assume defaultmethod named 'item'! + return [$val {*}$args] + } else { + #treat as list? + return [lindex $val $args] + } + } + } else { + return [set %ns%::o_%prop%] + } +} + + + + + + + + +proc ::p::predator::getprop_array {_ID_ prop args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + + #upvar 0 ::p::${OID}::o_${prop} prop + #1st try: assume array + if {[catch {array get ::p::${OID}::o_${prop}} result]} { + #treat as list (why?) + #!review + if {[info exists ::p::${OID}::o_${prop}]} { + array set temp [::list] + set i 0 + foreach element ::p::${OID}::o_${prop} { + set temp($i) $element + incr i + } + set result [array get temp] + } else { + error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" + } + } + return $result +} + +proc ::p::predator::setprop_template {prop _ID_ args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args] == 1} { + #return [set ::p::${OID}::o_%prop% [lindex $args 0]] + return [set ${ns}::o_%prop% [lindex $args 0]] + + } else { + if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { + #treat attempt to perform indexed write to nonexistant var, same as indexed write to array + + #2 args - single index followed by a value + if {[llength $args] == 2} { + return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] + } else { + #multiple indices + #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] + return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] + } + } else { + #treat as list + return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] + } + } +} + +#-------------------------------------- +#property read & write traces +#-------------------------------------- + + +proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} { + + #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' " + + #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain. + + if {[llength $idx]} { + if {[llength $idx] == 1} { + set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx] + } else { + lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx] + } + return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value + } else { + if {![info exists $refname]} { + set $refname [$get_cmd $_ID_ {*}$indices] + } else { + set newval [$get_cmd $_ID_ {*}$indices] + if {[set $refname] ne $newval} { + set $refname $newval + } + } + return + } +} + + + + +proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} { + #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" + + + #derive the name of the write command from the ref var. + set indices [lassign [split [namespace tail $refname] +] prop] + + + #assert - we will never have both a list in indices and an idx value + if {[llength $indices] && ($idx ne "")} { + #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x + #review - are there any datastructures which would/should allow this? + #this assertion is really just here as a sanity check for now + error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" + } + + #upvar #0 ::p::${OID}::_meta::map MAP + #puts "-->propref_trace_write map: $MAP" + + #temporarily deactivate refsync trace + #puts stderr -->1>--removing_trace_o_${field} +### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + #we need to catch, and re-raise any error that we may receive when writing the property + # because we have to reinstate the propvar_write_TraceHandler after the call. + #(e.g there may be a propertywrite handler that deliberately raises an error) + + set excludesync_refs $refname + set cmd ::p::${OID}::(SET)$prop + + + set f_error 0 + if {[catch { + + if {![llength $indices]} { + if {[string length $idx]} { + $cmd $_ID_ $idx [set ${refname}($idx)] + #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] + + } else { + $cmd $_ID_ [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] + } + } else { + #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" + $cmd $_ID_ {*}$indices [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices + } + + } result]} { + set f_error 1 + } + + + + + #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write + #reactivate refsync trace + #puts stderr "****** reactivating refsync trace on o_$field" + #puts stderr -->2>--reactivating_trace_o_${field} + ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + + if {$f_error} { + #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. + # ? return -code error $errMsg ? -errorinfo + + #!quick n dirty + #error $errorMsg + return -code error -errorinfo $::errorInfo $result + } else { + return $result + } +} + + + + + +proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { + #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'" + #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array') + + set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set + + #set updated_value [::p::predator::getprop_array $prop $_ID_] + #puts stderr "-->array_Trace updated_value:$updated_value" + if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} { + puts stderr "-->propref_trace_array error $errm" + array set $refname {} + } + + #return value ignored for +} + + +#-------------------------------------- +# +proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + + + #don't rely on variable name passed by trace - may have been 'upvar'ed + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar" + + set iflist [dict get $MAP interfaces level0] + + set plist [list] + + #!todo - get propertylist from cache on object(?) + foreach IFID [lreverse $iflist] { + dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { + #lassign $pdef v + if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} { + if {[array exists ::p::${OID}::o_${prop}]} { + lappend plist $prop [array get ::p::${OID}::o_${prop}] + } else { + #ignore - array only represents properties that have been set. + #error "property $v is not set" + #!todo - unset corresponding items in $refvar if needed? + } + } + } + } + array set $refvar $plist +} + + +proc ::p::predator::object_read_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" + + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + if {[string length $IID]} { + #property + if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { + puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" + } + } else { + #method + error "property '$idx' not found" + } +} + + +proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd + + #!todo - ??? + + if {![llength [info commands ::p::${OID}::$idx]]} { + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set found 0 + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set found 1 + break + } + } + + if {$found} { + unset ::p::${OID}::o_$idx + } else { + puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" + } + } +} + + +proc ::p::predator::object_write_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" + + + if {![llength [info commands ::p::${OID}::$idx]]} { + #!todo - create new property in interface upon attempt to write to non-existant? + # - or should we require some different kind of object-reference for that? + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + #$IID is now topmost interface in default iStack which has this property + + if {[string length $IID]} { + #write to defined property + + ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] + } else { + #!todo - allow write of method body back to underlying object? + #attempted write to 'method' ..undo(?) + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "cannot write to method '$idx'" + #for now - disallow + } + } + +} + + + +proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} { + #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + + set refindices [lassign [split [namespace tail $refname] +] prop] + #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop + #if there is no PropertyUnset command - we unset the underlying variable directly + + trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + + if {[catch { + + #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value + #i.e + if {[llength $refindices] && [string length $idx]} { + puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" + error "unexpected call to propref_trace_unset" + } + + + upvar #0 ::p::${OID}::_meta::map MAP + + set iflist [dict get $MAP interfaces level0] + #find topmost interface containing this $prop + set IID "" + foreach id [lreverse $iflist] { + if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + if {![string length $IID]} { + error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" + } + + + + + + + if {[string length $idx]} { + #eval "$_alias ${unset_}$field $idx" + #what happens to $refindices??? + + + #!todo varspace + + if {![llength $refindices]} { + #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop}($idx) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx + } + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx + } else { + #assert - won't get here + error 1a + + } + + } else { + if {[llength $refindices]} { + #error 2a + #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + #review - what about list-type property? + #if {[array exists ::p::${OID}::o_${prop}]} ??? + unset ::p::${OID}::o_${prop}($refindices) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices + } + + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices + + + } else { + #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + #ref is not of form prop+x etc and no idx in the trace - this is a plain unset + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop} + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" + } + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} + + } + } + + + + + } errM]} { + #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" + set ruler [string repeat - 80] + puts stderr "\t$ruler" + puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + puts stderr "\t$ruler" + puts stderr $errM + puts stderr "\t$ruler" + + } else { + #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + #puts stderr "*@*@*@*@ end propref_trace_unset - no error" + } + + trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + +} + + + + +proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} { + + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + + + if {[string length $triggeringRef]} { + set idx [lsearch -exact $refvars $triggeringRef] + if {$idx >= 0} { + set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] + } + } + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" + return + } + + + #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset + # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" + if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { + #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" + puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" + } + + + puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " + + + + upvar $vtraced SYNCVARIABLE + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + + + if {[array exists SYNCVARIABLE]} { + + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + + #set triggeringRefIdx $vidx + + if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { + set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] + } else { + set triggering_indices [list] + } + + + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + + + + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #check indices of triggering refvar match this refvars indices + + + if {$reftail eq [namespace tail $triggeringRef]} { + #!todo - add test + error "untested, possibly unused branch spuds2" + #puts "222222222222222222" + unset $refvar + } else { + + #error "untested - branch spuds2a" + + + } + + } else { + #!todo -add test + #reference is directly to property var + error "untested, possibly unused branch spuds3" + #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? + puts "\t33333333333333333333" + + if {[string length $triggeringRefIdx]} { + unset $refvar($triggeringRefIdx) + } + } + } + + } + + + + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + + + + +} + + +proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} { + + upvar $vtraced SYNCVARIABLE + + set refvars [::list] + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + + + #short_circuit breaks unset traces for array elements (why?) + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + return + } else { + puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + } + + if {[catch { + + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + + + if {[array exists SYNCVARIABLE]} { + + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + set triggeringRefIdx $vidx + + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + + + + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + unset $refvar + + } + + } + + + + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + } errM]} { + set ruler [string repeat * 80] + puts stderr "\t$ruler" + puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" + puts stderr "\t$ruler" + puts stderr $::errorInfo + puts stderr "\t$ruler" + + } + +} + +proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} { + error hmmmmm + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " + set refvars [::list] + + #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + #assert triggeringRef is in the list + if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { + error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" + } + set refposn [lsearch -exact $refvars $triggeringRef] + #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 + set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" + return [list refs_updates [list]] + } + + #suppress the propref_trace_* traces on all refvars + array set traces [::list] + array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." + #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync + #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? + #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #all other traces are 'external' + lappend external_traces($rv) $tinfo + #trace remove variable $rv $ops $cmd + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + if {![info exists SYNCVARIABLE]} { + error "WARNING: REVIEW why does $vartraced not exist here?" + } + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set treat_vtraced_as_array 1 + } else { + set treat_vtraced_as_array 0 + } + + set refs_updated [list] + set refs_deleted [list] ;#unset due to index no longer being relevant + if {$treat_vtraced_as_array} { + foreach refvar $refvars { + #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + if {[llength $indices]} { + if {[llength $indices] == 1} { + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + #error "untested xxx-a" + set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] + lappend refs_updated $refvar + } else { + #test exists + #error "xxx-ok single index" + #updating a different part of the property - nothing to do + } + } else { + #nested index + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + if {[llength $ref_indices] == 1} { + #error "untested xxx-b1" + set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] + } else { + #assert llength $ref_indices > 1 + #NOTE - we cannot test index equivalence reliably/simply just by comparing indices + #compare by value + + if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { + #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" + if {[set $refvar] ne $possiblyNewVal} { + set $refvar $possiblyNewVal + } + } else { + #fail to retrieve underlying value corrsponding to these $indices + unset $refvar + } + } + } else { + #test exists + #error "untested xxx-ok deepindex" + #updating a different part of the property - nothing to do + } + } + } else { + error "untested xxx-c" + + } + + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + if {[llength $indices] == 1} { + set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] + } else { + lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] + } + lappend refs_updated $refvar + } else { + error "untested yyy" + set $refvar $SYNCVARIABLE + } + } + } + } else { + #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) + # + foreach refvar $refvars { + #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + + if {[llength $indices]} { + #see if this update would affect this curried ref + #1st see if we can short-circuit our comparison based on numeric-indices + if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { + #both sets of indices are purely numeric (no end end-1 etc) + set rlen [llength $ref_indices] + set ilen [llength $indices] + set minlen [expr {min($rlen,$ilen)}] + set matched_firstfew_indices 1 ;#assume the best + for {set i 0} {$i < $minlen} {incr i} { + if {[lindex $ref_indices $i] ne [lindex $indices $i]} { + break ;# + } + } + if {!$matched_firstfew_indices} { + #update of this refvar not required + #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" + break ;#break to next refvar in the foreach loop + } + } + #failed to short-circuit + + #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set $refvar] ne $newval} { + set $refvar $newval + lappend refs_updated $refvar + } + + } else { + #we must be updating the entire variable - so this curried ref will either need to be updated or unset + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set ${refvar}] ne $newval} { + set ${refvar} $newval + lappend refs_updated $refvar + } + } + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + #error "untested zzz-a" + set newval [lindex $SYNCVARIABLE $indices] + if {[lindex [set $refvar] $indices] ne $newval} { + lset ${refvar} $indices $newval + lappend refs_updated $refvar + } + } else { + if {[set ${refvar}] ne $SYNCVARIABLE} { + set ${refvar} $SYNCVARIABLE + lappend refs_updated $refvar + } + } + + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + + #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + } + foreach rv [array names external_traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + #trace add variable $rv $ops $cmd + } + } + } + + + return [list updated_refs $refs_updated] +} + +#purpose: update all relevant references when context variable changed directly +proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { + #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. + #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler + + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" + set t_info [trace vinfo $vtraced] + foreach t_spec $t_info { + set t_ops [lindex $t_spec 0] + if {$op in $t_ops} { + puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" + } + } + + #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- + #vtype = array | array-item | list | simple + + set refvars [::list] + + ############################ + #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! + #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) + #The alternative 'info vars' does not trigger traces + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + ############################ + + #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" + return + } + + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars + array set predator_traces [::list] + #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. + #ie for something like 'trace add variable someref {write read array} somefunc' + # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace + array set external_read_traces [::list] ;#pure read traces the library user may have added + array set external_readetc_traces [::list] ;#read + something else traces the library user may have added + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + #if {$ops in {read write unset array}} {} + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend predator_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #other traces + # puts "##trace $tinfo" + if {"read" in $ops} { + if {[llength $ops] == 1} { + #pure read - + lappend external_read_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + } else { + #mixed operation trace - remove and reinstall without the 'read' + lappend external_readetc_traces($rv) $tinfo + set other_ops [lsearch -all -inline -not $ops "read"] + trace remove variable $rv $ops $cmd + #reinstall trace for non-read operations only + trace add variable $rv $other_ops $cmd + } + } + } + } + } + + + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set vtracedIsArray 1 + } else { + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" + #puts "**write*********** refvars: $refvars" + + #!todo? unroll foreach into multiple foreaches within ifs? + #foreach refvar $refvars {} + + + #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" + if {[string length $vidx]} { + #indexable + if {$vtracedIsArray} { + + foreach refvar $refvars { + #puts stderr " - - a refvar $refvar vidx: $vidx" + set tail [namespace tail $refvar] + if {[string match "${prop}+*" $tail]} { + #refvar is curried + #only set if vidx matches curried index + #!todo -review + set idx [lrange [split $tail +] 1 end] + if {$idx eq $vidx} { + set newval [set SYNCVARIABLE($vidx)] + if {[set $refvar] ne $newval} { + set ${refvar} $newval + } + #puts stderr "=a.1=> updated $refvar" + } + } else { + #refvar is simple + set newval [set SYNCVARIABLE($vidx)] + if {![info exists ${refvar}($vidx)]} { + #new key for this array + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } else { + set oldval [set ${refvar}($vidx)] + if {$oldval ne $newval} { + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } + } + #puts stderr "=a.2=> updated ${refvar} $vidx" + } + } + + + + } else { + + + foreach refvar $refvars { + upvar $refvar internal_property_reference + #puts stderr " - - b vidx: $vidx" + + #!? could be object not list?? + #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? + #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) + #There would still be an edge case of an initial write of a list of objects of length 1. + if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { + error "untested review!" + #the o_prop is object-shaped + #assumes object has a defaultmethod which accepts indices + set newval [[set $SYNCVARIABLE] {*}$vidx] + + } else { + set newval [lindex $SYNCVARIABLE {*}$vidx] + #if {[set $refvar] ne $newval} { + # set $refvar $newval + #} + if {$internal_property_reference ne $newval} { + set internal_property_reference $newval + } + + } + #puts stderr "=b=> updated $refvar" + } + + + } + + + + } else { + #no vidx + + if {$vtracedIsArray} { + + + foreach refvar $refvars { + set targetref_tail [namespace tail $refvar] + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + + #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" + if {$targetref_is_indexed} { + #curried array item ref of the form ${prop}+x or ${prop}+x+y etc + + #unindexed write on a property that is acting as an array.. + + #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. + + #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). + # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. + puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" + } else { + #How do we know what to write to array ref? + puts stderr "\tc.2 WARNING: unimplemented/unused?" + #error no_tests_for_branch + + #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation + #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate + array unset ${refvar} + array set ${refvar} [array get SYNCVARIABLE] + } + } + + + + } else { + foreach refvar $refvars { + #puts stderr "\t\t_________________[namespace current]" + set targetref_tail [namespace tail $refvar] + upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + if {$targetref_is_indexed} { + #puts "XXXXXXXXX vtraced:$vtraced" + #reference curried with index(es) + #we only set indexed refs if value has changed + # - this not required to be consistent with standard list-containing variable traces, + # as normally list elements can't be traced seperately anyway. + # + + + #only bother checking a ref if no setVia index + # i.e some operation on entire variable so need to test synchronisation for each element-ref + set targetref_indices [lrange [split $targetref_tail +] 1 end] + set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] + #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal + #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" + } + + + } else { + #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! + + #puts stderr "- d2 set" + #puts "refvar: [set $refvar]" + #puts "SYNCVARIABLE: $SYNCVARIABLE" + + #if {[set $refvar] ne $SYNCVARIABLE} { + # set $refvar $SYNCVARIABLE + #} + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE + } + + } + } + + + } + + } + + + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names predator_traces] { + foreach tinfo $predator_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + foreach rv [array names external_traces] { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + + +} + +# end propvar_write_TraceHandler + + + + + + + + + + + + + + + + +# + +#returns 0 if method implementation not present for interface +proc ::p::predator::method_chainhead {iid method} { + #Interface proc + # examine the existing command-chain + set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex) + set cmdchain [list] + + set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}] + set maxversion 0 + #loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob. + foreach test [lsort -dictionary $candidates] { + set c [namespace tail $test] + if {[regexp $re $c _match version]} { + lappend cmdchain $c + if {$version > $maxversion} { + set maxversion $version + } + } + } + return $maxversion +} + + + + + +#this returns a script that upvars vars for all interfaces on the calling object - +# - must be called at runtime from a method +proc ::p::predator::upvar_all {_ID_} { + #::set OID [lindex $_ID_ 0 0] + ::set OID [::lindex [::dict get $_ID_ i this] 0 0] + ::set decl {} + #[set ::p::${OID}::_meta::map] + #[dict get [lindex [dict get $_ID_ i this] 0 1] map] + + ::upvar #0 ::p::${OID}::_meta::map MAP + #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" + #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] + + ::foreach ifid [dict get $MAP interfaces level0] { + if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} { + ::array unset nsvars + ::array set nsvars [::list] + ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { + ::set varspace [::dict get $vinfo varspace] + ::lappend nsvars($varspace) $vname + } + #nsvars now contains vars grouped by varspace. + + ::foreach varspace [::array names nsvars] { + if {$varspace eq ""} { + ::set ns ::p::${OID} + } else { + if {[::string match "::*" $varspace]} { + ::set ns $varspace + } else { + ::set ns ::p::${OID}::$varspace + } + } + + ::append decl "namespace upvar $ns " + ::foreach vname [::set nsvars($varspace)] { + ::append decl "$vname $vname " + } + ::append decl " ;\n" + } + ::array unset nsvars + } + } + ::return $decl +} + +#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator) +proc ::p::predator::runtime_vardecls {} { + set result "::eval \[::p::predator::upvar_all \$_ID_\]" + #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" + + #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" + #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" + #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" + return $result +} + + + + + + +#OBSOLETE!(?) - todo - move stuff out of here. +proc ::p::predator::compile_interface {IFID caller_ID_} { + upvar 0 ::p::${IFID}:: IFACE + + #namespace eval ::p::${IFID} { + # namespace ensemble create + #} + + #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables + + namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + #set varDecls {} + #if {[llength $o_variables]} { + # #puts "*********!!!! $vlist" + # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] " + # foreach vdef $o_variables { + # append varDecls "[lindex $vdef 0] [lindex $vdef 0] " + # } + # append varDecls \n + #} + + #runtime gathering of vars from other interfaces. + #append varDecls [runtime_vardecls] + + set varDecls [runtime_vardecls] + + + + #implement methods + + #!todo - avoid globs on iface array? maintain list of methods in another slot? + #foreach {n mname} [array get IFACE m-1,name,*] {} + + + #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. + + + + #implement property getters/setters/unsetters + #'setter' overrides + #pw short for propertywrite + foreach {n property} [array get IFACE pw,name,*] { + if {[string length $property]} { + #set property [lindex [split $n ,] end] + + #!todo - next_script + #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] + + set maxversion [::p::predator::method_chainhead $IFID (SET)$property] + set chainhead [expr {$maxversion + 1}] + set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 + + set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? + + set body $IFACE(pw,body,$property) + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" + } + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + set maxversion [::p::predator::method_chainhead $IFID $property] + set headid [expr {$maxversion + 1}] + + proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body + + interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid + + #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body + } + } + #'unset' overrides + + dict for {property handler_info} $o_propertyunset_handlers { + + set body [dict get $handler_info body] + set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array + + set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? + + + + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body" + + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + + #implement + #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern "_dontcare_" + } + proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body + + + #chainhead pointer + interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid + } + + + + interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) + + #the usual case will have no destructor - so use info exists to check. + + if {[info exists ::p::${IFID}::_iface::o_destructor_body]} { + #!todo - chained destructors (support @next@). + #set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID] + set next NEXT + + set body [set ::p::${IFID}::_iface::o_destructor_body] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body" + } + #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + proc ::p::${IFID}::___system___destructor _ID_ $body + } + + + if {[info exists o_unknown]} { + #use 'apply' somehow? + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + + #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] + } + + + return +} + + + + + + + +#'info args' - assuming arbitrary chain of 'interp aliases' +proc ::p::predator::command_info_args {cmd} { + if {[llength [set next [interp alias {} $cmd]]]} { + set curriedargs [lrange $next 1 end] + + if {[catch {set arglist [info args [lindex $next 0]]}]} { + set arglist [command_info_args [lindex $next 0]] + } + #trim curriedargs + return [lrange $arglist [llength $curriedargs] end] + } else { + info args $cmd + } +} + + +proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { + if {[llength $args]} { + tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args + } else { + if {[llength $nextArgs] > 1} { + set argVals [::list] + set i 0 + foreach arg [lrange $nextArgs 1 end] { + upvar 1 $arg $i + if {$arg eq "args"} { + #need to check if 'args' is actually available in caller + if {[info exists $i]} { + set argVals [concat $argVals [set $i]] + } + } else { + lappend argVals [set $i] + } + } + tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals + } else { + tailcall ::p::${IFID}::_iface::$mname $_ID_ + } + } +} + +#---------------------------------------------------------------------------------------------- +proc ::p::predator::next_script {IFID method caller caller_ID_} { + + if {$caller eq "(CONSTRUCTOR).1"} { + return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}] + } elseif {$caller eq "$method.1"} { + #delegate to next interface lower down the stack which has a member named $method + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } elseif {[string match "(GET)*.2" $caller]} { + # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. + + #jmn + set prop [string trimright $caller 1234567890] + set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing . + + if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} { + #return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}] + return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] + } else { + #we can actually have a property read without a property or a method of that name - but it could also match the name of a method. + # (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something) + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } + } elseif {[string match "(SET)*.2" $caller]} { + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } else { + #this branch will also handle (SET)*.x and (GET)*.x where x >2 + + #puts stdout "............next_script IFID:$IFID method:$method caller:$caller" + set callerid [string range $caller [string length "$method."] end] + set nextid [expr {$callerid - 1}] + + if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} { + #not a proc directly on this interface - presumably an alias made by something like linkcopy_interface. + #puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid" + set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid] + } + + return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] + } +} + +proc ::p::predator::do_next_if {_ID_ IFID method args} { + #puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' (((" + + #set invocants [dict get $_ID_ i] + #set this_invocantdata [lindex [dict get $invocants this] 0] + #lassign $this_invocantdata OID this_info + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set interfaces [dict get $MAP interfaces level0] + set patterninterfaces [dict get $MAP interfaces level1] + + set L0_posn [lsearch $interfaces $IFID] + if {$L0_posn == -1} { + error "(::p::predator::do_next_if) called with interface not present at level0 for this object" + } elseif {$L0_posn > 0} { + #set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack + set lower_interfaces [lrange $interfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {[string match "(GET)*" $method]} { + #do not test o_properties here! We need to call even if there is no underlying property on this interface + #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) + # relevant test: higher_order_propertyread_chaining + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + } elseif {[string match "(SET)*" $method]} { + #must be called even if there is no matching $method in o_properties + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + } elseif {[string match "(UNSET)*" $method]} { + #review untested + #error "do_next_if (UNSET) untested" + #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'" + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + + } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} { + if {[llength $args]} { + #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args" + + #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args + + #!todo - handle case where llength $args is less than number of args for subinterface command + #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set) + + #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature) + set head [interp alias {} ::p::${if_sub}::_iface::$method] + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc + set argx [list] + foreach a $nextArgs { + lappend argx "\$a" + } + + #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared + + if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} { + tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args + } else { + #todo - upvars required for tail end of arglist + tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args + } + + } else { + #auto-set: upvar vars from calling scope + #!todo - robustify? alias not necessarily matching command name.. + set head [interp alias {} ::p::${if_sub}::_iface::$method] + + + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc + if {[llength $nextArgs] > 1} { + set argVals [::list] + set i 0 + foreach arg [lrange $nextArgs 1 end] { + upvar 1 $arg $i + if {$arg eq "args"} { + #need to check if 'args' is actually available in caller + if {[info exists $i]} { + set argVals [concat $argVals [set $i]] + } + } else { + lappend argVals [set $i] + } + } + #return [$head $_ID_ {*}$argVals] + tailcall $head $_ID_ {*}$argVals + } else { + #return [$head $_ID_] + tailcall $head $_ID_ + } + } + } elseif {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + #return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args] + xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } +} + + +#only really makes sense for (CONSTRUCTOR) calls. +#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class. +proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { + #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" + + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + #set OID [lindex [dict get $invocants this] 0 0] + #upvar #0 ::p::${OID}::_meta::map map + #lassign [lindex $map 0] OID alias itemCmd cmd + + + set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] + upvar #0 ::p::${caller_OID}::_meta::map callermap + + #set interfaces [lindex $map 1 0] + set patterninterfaces [dict get $callermap interfaces level1] + + set L0_posn [lsearch $patterninterfaces $IFID] + if {$L0_posn == -1} { + error "do_next_pattern_if called with interface not present at level1 for this object" + } elseif {$L0_posn > 0} { + + + set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } +} + + + + + +#------------------------------------------------------------------------------------------------ + + + + + +#------------------------------------------------------------------------------------- +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### + + +#!todo - can we just call new_object somehow to create this? + + #until we have a version of Tcl that doesn't have 'creative writing' scope issues - + # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. + # (see http://mini.net/tcl/1030 'Dangers of creative writing') +namespace eval ::p::-1 { + #namespace ensemble create + + namespace eval _ref {} + namespace eval _meta {} + + namespace eval _iface { + variable o_usedby + variable o_open + variable o_constructor + variable o_variables + variable o_properties + variable o_methods + variable o_definition + variable o_varspace + variable o_varspaces + + array set o_usedby [list i0 1] ;#!todo - review + #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? + + set o_open 1 + set o_constructor [list] + set o_variables [list] + set o_properties [dict create] + set o_methods [dict create] + array set o_definition [list] + set o_varspace "" + set o_varspaces [list] + } +} + + +# + +#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}] +interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}] + + +upvar #0 ::p::-1::_iface::o_definition def + + +#! concatenate -> compose ?? +dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}} +proc ::p::-1::Concatenate {_ID_ target args} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {![string match "::*" $target]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set target ::$target + } else { + set target ${ns}::$target + } + } + #add > character if not already present + set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] + set _target [string map {::> ::} $target] + + set ns [namespace qualifiers $target] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } + + if {![llength [info commands $target]]} { + #degenerate case - target does not exist + #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone' + #review - should be 'Copy' so it has object state from namespaces and variables? + return [::p::-1::Clone $_ID_ $target {*}$args] + + #set TARGETMAP [::p::predator::new_object $target] + #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd + + } else { + #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] + set TARGETMAP [$target --] + + lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd + + #Merge lastmodified(?) level0 and level1 interfaces. + + } + + return $target +} + + + +#Object's Base-Interface proc with itself as curried invocant. +#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant +#namespace eval ::p::-1 {namespace export Create} +dict set ::p::-1::_iface::o_methods Define {arglist definitions} +#define objects in one step +proc ::p::-1::Define {_ID_ definitions} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias default_method cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + + #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack + #set IFID0 [lindex $interfaces 0] + #set IFID1 [lindex $patterns 0] ;#1st pattern + + #set IFID_TOP [lindex $interfaces end] + set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] + + #set ns ::p::${OID} + + #set script [string map [list %definitions% $definitions] { + # if {[lindex [namespace path] 0] ne "::p::-1"} { + # namespace path [list ::p::-1 {*}[namespace path]] + # } + # %definitions% + # namespace path [lrange [namespace path] 1 end] + # + #}] + + set script [string map [list %id% $_ID_ %definitions% $definitions] { + set ::p::-1::temp_unknown [namespace unknown] + + namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] + + + #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] + + + %definitions% + + + namespace unknown ${::p::-1::temp_unknown} + return + }] + + + + #uplevel 1 $script ;#this would run the script in the global namespace + #run script in the namespace of the open interface, this allows creating of private helper procs + #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack + #namespace inscope ::p::${OID} $script + namespace eval ::p::${OID} $script + #return $cmd +} + + +proc ::p::predator::redirect {func args} { + + #todo - review tailcall - tests? + if {![llength [info commands ::p::-1::$func]]} { + #error "invalid command name \"$func\"" + tailcall uplevel 1 [list ::unknown $func {*}$args] + } else { + tailcall uplevel 1 [list ::p::-1::$func {*}$args] + } +} + + +#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review. +dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}} +proc ::p::-1::Construct {_ID_ argpairs body args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace + + set ARGSETTER {} + foreach {argname argval} $argpairs { + append ARGSETTER "set $argname $argval\n" + } + #$_self (VIOLATE) $ARGSETTER$body + + set body $ARGSETTER\n$body + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + # puts stderr "\t runtime_vardecls in Construct $varDecls" + } + + set next "\[error {next not implemented}\]" + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + #namespace eval ::p::${iid_top} $body + + #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] + #does this handle Varspace before constructor? + return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] +} + + + + + +#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects +namespace eval ::p::3 {} +proc ::p::3::_create {child {OID "-2"}} { + #puts stderr "::p::3::_create $child $OID" + set _child [string map {::> ::} $child] + if {$OID eq "-2"} { + #set childmapdata [::p::internals::new_object $child] + #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] + set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } else { + set child_ID $OID + #set _childmap [::p::internals::new_object $child "" $child_ID] + ::p::internals::new_object $child "" $child_ID + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } + + #-------------- + + set oldinterfaces [dict get $CHILDMAP interfaces] + dict set oldinterfaces level0 [list 2] + set modifiedinterfaces $oldinterfaces + dict set CHILDMAP interfaces $modifiedinterfaces + + #-------------- + + + + + #puts stderr ">>>> creating alias for ::p::$child_ID" + #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" + + #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! + #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] + #puts stderr ">>>[interp alias {} ::p::$child_ID]" + + + + #--------------- + namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties + foreach method [dict keys $o_methods] { + #todo - change from interp alias to context proc + interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method + } + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop + + } + ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] + #--------------- + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + return $child +} + +#configure -prop1 val1 -prop2 val2 ... +dict set ::p::-1::_iface::o_methods Configure {arglist args} +proc ::p::-1::Configure {_ID_ args} { + + #!todo - add tests. + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd this + + if {![expr {([llength $args] % 2) == 0}]} { + error "expected even number of Configure args e.g '-property1 value1 -property2 value2'" + } + + #Do a separate loop to check all the arguments before we run the property setting loop + set properties_to_configure [list] + foreach {argprop val} $args { + if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} { + error "expected Configure args in the form: '-property1 value1 -property2 value2'" + } + lappend properties_to_configure [string range $argprop 1 end] + } + + #gather all valid property names for all level0 interfaces in the relevant interface stack + set valid_property_names [list] + set iflist [dict get $MAP interfaces level0] + foreach id [lreverse $iflist] { + set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]] + foreach if_prop $interface_property_names { + if {$if_prop ni $valid_property_names} { + lappend valid_property_names $if_prop + } + } + } + + foreach argprop $properties_to_configure { + if {$argprop ni $valid_property_names} { + error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names" + } + } + + set top_IID [lindex $iflist end] + #args ok - go ahead and set all properties + foreach {prop val} $args { + set property [string range $prop 1 end] + #------------ + #don't use property ref unnecessarily - leaves property refs hanging around which traces need to update + #ie don't do this here: set [$this . $property .] $val + #------------- + ::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val] + } + return +} + + + + + + +dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid} +proc ::p::-1::AddPatternInterface {_ID_ iid} { + #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces + + + + #it is theoretically possible to have the same interface present multiple times in an iStack. + # #!todo -review why/whether this is useful. should we disallow it and treat as an error? + + lappend existing_ifaces $iid + #lset map {1 1} $existing_ifaces + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + + #lset invocant {1 1} $existing_ifaces + +} + + +#!todo - update usedby ?? +dict set ::p::-1::_iface::o_methods AddInterface {arglist iid} +proc ::p::-1::AddInterface {_ID_ iid} { + #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + + lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. + set this_invocant [lindex $list_of_invocants_for_role_this 0] + + lassign $this_invocant OID _etc + + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level0] + + lappend existing_ifaces $iid + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + return [dict get $extracted_sub_dict level0] +} + + + +# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module. +# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist +# and 'CreateOverlay' for the case where the target/child object already exists. +# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence, +# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object. +# 'CreateNew' will raise an error if the target already exists +# 'CreateOverlay' will raise an error if the target object does not exist. +# 'Create' will work in either case. Creating the target if necessary. + + +#simple form: +# >somepattern .. Create >child +#simple form with arguments to the constructor: +# >somepattern .. Create >child arg1 arg2 etc +#complex form - specify more info about the target (dict keyed on childobject name): +# >somepattern .. Create {>child {-id 1}} +#or +# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] +#complex form - with arguments to the contructor: +# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc +dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}} +proc ::p::-1::Create {_ID_ target_spec args} { + #$args are passed to constructor + if {[llength $target_spec] ==1} { + set child $target_spec + set targets [list $child {}] + } else { + set targets $target_spec + } + + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) + + foreach {child target_spec_dict} $targets { + #puts ">>>::p::-1::Create $_ID_ $child $args <<<" + + + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + + + + #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID" + + #child should already be fully ns qualified (?) + #ensure it is has a pattern-object marker > + #puts stderr ".... $child (nsqual: [namespace qualifiers $child])" + + + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + #puts "parent: $OID -> child:$child Patterns $patterns" + + #todo - change to dict of interface stacks + set IFID0 [lindex $interfaces 0] + set IFID1 [lindex $patterns 0] ;#1st pattern + + #upvar ::p::${OID}:: INFO + + if {![string match {::*} $child]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set child ::$child + } else { + set child ${ns}::$child + } + } + + + #add > character if not already present + set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >] + set _child [string map {::> ::} $child] + + set ns [namespace qualifiers $child] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } + + + #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls. + set new_interfaces [list] + + if {![llength $patterns]} { + ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child" + #lappend patterns [::p::internals::new_interface $OID] + + #lset invocant {1 1} $patterns + ##update our command because we changed the interface list. + #set IFID1 [lindex $patterns 0] + + #set patterns [list [::p::internals::new_interface $OID]] + + #set patterns [list [::p::internals::new_interface]] + + #set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id + #set patterns [list [set iid [incr ::p::ID]]] + set patterns [list [set iid [::p::get_new_object_id]]] + + #--------- + #set iface [::p::>interface .. Create ::p::ifaces::>$iid] + #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid + + #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation + lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid] + + #--------- + + #puts "??> p::>interface .. Create ::p::ifaces::>$iid" + #puts "??> [::p::ifaces::>$iid --]" + #set [$iface . UsedBy .] + } + set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] + + #if {![llength [info commands $child]]} {} + + if {[namespace which $child] eq ""} { + #normal case - target/child does not exist + set is_new_object 1 + + if {[dict exists $target_spec_dict -id]} { + set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]] + } else { + set childmapdata [::p::internals::new_object $child] + } + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + + + + #child initially uses parent's level1 interface as it's level0 interface + # child has no level1 interface until PatternMethods or PatternProperties are added + # (or applied via clone; or via create with a parent with level2 interface) + #set child_IFID $IFID1 + + #lset CHILDMAP {1 0} [list $IFID1] + #lset CHILDMAP {1 0} $patterns + + set extracted_sub_dict [dict get $CHILDMAP interfaces] + dict set extracted_sub_dict level0 $patterns + dict set CHILDMAP interfaces $extracted_sub_dict + + #why write back when upvared??? + #review + set ::p::${child_ID}::_meta::map $CHILDMAP + + #::p::predator::remap $CHILDMAP + + #interp alias {} $child {} ::p::internals::predator $CHILDMAP + + #set child_IFID $IFID1 + + #upvar ::p::${child_ID}:: child_INFO + + #!todo review + #set n ::p::${child_ID} + #if {![info exists ${n}::-->PATTERN_ANCHOR]} { + # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" + # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack + # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" + # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] + #} + + set ifaces_added $patterns + + } else { + #overlay/mixin case - target/child already exists + set is_new_object 0 + + #set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1] + set childmapdata [$child --] + + + #puts stderr " *** $cmd .. Create -> target $child already exists!!!" + #puts " **** CHILDMAP: $CHILDMAP" + #puts " ****" + + #puts stderr " ---> Properties: [$child .. Properties . names]" + #puts stderr " ---> Methods: [$child .. Properties . names]" + + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + + #set child_IFID [lindex $CHILDMAP 1 0 end] + #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} { + # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] + # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP + #} + ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces + #::p::merge_interface $IFID1 $child_IFID + + + set existing_interfaces [dict get $CHILDMAP interfaces level0] + set ifaces_added [list] + foreach p $patterns { + if {$p ni $existing_interfaces} { + lappend ifaces_added $p + } + } + + if {[llength $ifaces_added]} { + #lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added] + set extracted_sub_dict [dict get $CHILDMAP interfaces] + dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added] + dict set CHILDMAP interfaces $extracted_sub_dict + #set ::p::${child_ID}::_meta::map $CHILDMAP ;#why? + #::p::predator::remap $CHILDMAP + } + } + + #do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty + if {$parent_patterndefaultmethod ne ""} { + set child_defaultmethod $parent_patterndefaultmethod + set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata] + lset CHILD_INVOCANTDATA 2 $child_defaultmethod + dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA + #update the child's _ID_ + interp alias {} $child_alias {} ;#first we must delete it + interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}] + + #! object_command was initially created as the renamed alias - so we have to do it again + rename $child_alias $child + trace add command $child rename [list $child .. Rename] + } + #!todo - review - dont we already have interp alias entries for every method/prop? + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + + + + + + set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call. + + + + #------------------------------------------------------------------------------------ + #create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail. + # - All variables under the namespace - not just those declared as Variables or Properties + # - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces. + # - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write. + + #NOTE - do not use the objectID as the sole identifier for the snapshot namespace. + # - there may be multiple active snapshots for a single object if it overlays itself during a constructor, + # and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call. + # - we will use an ever-increasing snapshotid to form part of ns_snap + set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create. + + #!todo - this should look at child namespaces (recursively?) + #!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces. + # (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace) + + namespace eval $ns_snap {} + foreach vname [info vars ::p::${child_ID}::*] { + set shortname [namespace tail $vname] + if {[array exists $vname]} { + array set ${ns_snap}::${shortname} [array get $vname] + } elseif {[info exists $vname]} { + set ${ns_snap}::${shortname} [set $vname] + } else { + #variable exists without value (e.g created by 'variable' command) + namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist' + } + } + #------------------------------------------------------------------------------------ + + + + + + + + + + #puts "====>>> ifaces_added $ifaces_added" + set idx 0 + set idx_count [llength $ifaces_added] + set highest_constructor_IFID "" + foreach IFID $ifaces_added { + incr idx + #puts "--> adding iface $IFID " + namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + if {[llength $o_varspaces]} { + foreach vs $o_varspaces { + #ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work. + if {[string match "::*" $vs]} { + namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all. + } else { + namespace eval ::p::${child_ID}::$vs {} + } + } + } + + if {$IFID != 2} { + #>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list. + if {![info exists o_usedby(i$child_ID)]} { + set o_usedby(i$child_ID) $child_alias + } + + #compile and close the interface only if it is shared + if {$o_open} { + ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_ + set o_open 0 + } + } + + + + package require struct::set + + set propcmds [list] + foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] { + set cmd [namespace tail $cmd] + #may contain multiple results for same prop e.g (GET)x.3 + set cmd [string trimright $cmd 0123456789] + set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals + lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. + } + set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. + #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. + foreach property $propcmds { + #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n" + interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces + interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property + } + + set propcmds [list] + foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] { + set cmd [namespace tail $cmd] + #may contain multiple results for same prop e.g (GET)x.3 + set cmd [string trimright $cmd 0123456789] + set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals + lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. + } + set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. + #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. + foreach property $propcmds { + interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces + } + + + foreach method [dict keys $o_methods] { + set arglist [dict get $o_methods $method arglist] + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + + #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method + + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #proc calls the method in the interface - which is an interp alias to the head of the implementation chain + + + proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IFID}::_iface::$method \$_ID_ $argvals + }] + + #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] { + # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ + #}] + + + } + + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + set varspace [dict get $pdef varspace] + if {![string length $varspace]} { + set ns ::p::${child_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${child_ID}::$varspace + } + } + if {[dict exists $pdef default]} { + if {![info exists ${ns}::o_$prop]} { + #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) + set ${ns}::o_$prop [dict get $pdef default] + } + } + #! May be replaced by a method with the same name + if {$prop ni [dict keys $o_methods]} { + interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop + } + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop + } + + + + #variables + #foreach vdef $o_variables { + # if {[llength $vdef] == 2} { + # #there is a default value defined. + # lassign $vdef v default + # if {![info exists ::p::${child_ID}::$v]} { + # set ::p::${child_ID}::$v $default + # } + # } + #} + dict for {vname vdef} $o_variables { + if {[dict exists $vdef default]} { + #there is a default value defined. + set varspace [dict get $vdef varspace] + if {$varspace eq ""} { + set ns ::p::${child_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${child_ID}::$varspace + } + } + set ${ns}::$vname [dict get $vdef default] + } + } + + + #!todo - review. Write tests for cases of multiple constructors! + + #We don't want to the run constructor for each added interface with the same set of args! + #run for last one - rely on constructor authors to use @next@ properly? + if {[llength [set ::p::${IFID}::_iface::o_constructor]]} { + set highest_constructor_IFID $IFID + } + + if {$idx == $idx_count} { + #we are processing the last interface that was added - now run the latest constructor found + if {$highest_constructor_IFID ne ""} { + #at least one interface has a constructor + if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} { + #puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP" + if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} { + set constructor_failure 1 + set constructor_errorInfo $::errorInfo ;#cache it immediately. + break + } + } + } + } + + if {[info exists o_unknown]} { + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + + + #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] + #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown] + } + } + + if {$constructor_failure} { + if {$is_new_object} { + #is Destroy enough to ensure that no new interfaces or objects were left dangling? + $child .. Destroy + } else { + #object needs to be returned to a sensible state.. + #attempt to rollback all interface additions and object state changes! + puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n" + #remove variables from the object's namespace - which don't exist in the snapshot. + set snap_vars [info vars ${ns_snap}::*] + puts "ns_snap '$ns_snap' vars'${snap_vars}'" + foreach vname [info vars ::p::${child_ID}::*] { + set shortname [namespace tail $vname] + if {"${ns_snap}::$shortname" ni "$snap_vars"} { + #puts "--- >>>>> unsetting $shortname " + unset -nocomplain $vname + } + } + + #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces) + #values of vars may also have Changed + #todo - consider traces? what is the correct behaviour? + # - some application traces may have fired before the constructor error occurred. + # Should the rollback now also trigger traces? + #probably yes. + + #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value + foreach vname $snap_vars { + #puts stdout "@@@@@@@@@@@ restoring $vname" + #flush stdout + + + set shortname [namespace tail $vname] + set target ::p::${child_ID}::$shortname + if {$target in [info vars ::p::${child_ID}::*]} { + set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only' + } else { + set present 0 + } + + if {[array exists $vname]} { + #restore 'array' variable + if {!$present} { + array set $target [array get $vname] + } else { + if {[array exists $target]} { + #unset superfluous elements + foreach key [array names $target] { + if {$key ni [array names $vname]} { + array unset $target $key + } + } + #.. and write only elements that have changed. + foreach key [array names $vname] { + if {[set ${target}($key)] ne [set ${vname}($key)]} { + set ${target}($key) [set ${vname}($key)] + } + } + } else { + #target has been changed to a simple variable - unset it and recreate the array. + unset $target + array set $target [array get $vname] + } + } + } elseif {[info exists $vname]} { + #restore 'simple' variable + if {!$present} { + set $target [set $vname] + } else { + if {[array exists $target]} { + #target has been changed to array - unset it and recreate the simple variable. + unset $target + set $target [set $vname] + } else { + if {[set $target] ne [set $vname]} { + set $target [set $vname] + } + } + } + } else { + #restore 'declared' variable + if {[array exists $target] || [info exists $target]} { + unset -nocomplain $target + } + namespace eval ::p::${child_ID} [list variable $shortname] + } + } + } + namespace delete $ns_snap + return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error + } + namespace delete $ns_snap + + } + + + + return $child +} + +dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} +#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied* +# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*) +# Also: Any 'open' interfaces on the parent become closed on clone! +proc ::p::-1::Clone {_ID_ clone args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set invocants [dict get $_ID_ i] + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + + set _cmd [string map {::> ::} $cmd] + set tail [namespace tail $_cmd] + + + #obsolete? + ##set IFID0 [lindex $map 1 0 end] + #set IFID0 [lindex [dict get $MAP interfaces level0] end] + ##set IFID1 [lindex $map 1 1 end] + #set IFID1 [lindex [dict get $MAP interfaces level1] end] + + + if {![string match "::*" $clone]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set clone ::$clone + } else { + set clone ${ns}::$clone + } + } + + + set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] + set _clone [string map {::> ::} $clone] + + + set cTail [namespace tail $_clone] + + set ns [namespace qualifiers $clone] + if {$ns eq ""} { + set ns "::" + } + + namespace eval $ns {} + + + #if {![llength [info commands $clone]]} {} + if {[namespace which $clone] eq ""} { + set clonemapdata [::p::internals::new_object $clone] + } else { + #overlay/mixin case - target/clone already exists + #set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1] + set clonemapdata [$clone --] + } + set clone_ID [lindex [dict get $clonemapdata invocantdata] 0] + + upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP + + + #copy patterndata element of MAP straight across + dict set CLONEMAP patterndata [dict get $MAP patterndata] + set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata] + lset CLONE_INVOCANTDATA 2 $parent_defaultmethod + dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA + lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone + + #update the clone's _ID_ + interp alias {} $clone_alias {} ;#first we must delete it + interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}] + + #! object_command was initially created as the renamed alias - so we have to do it again + rename $clone_alias $clone + trace add command $clone rename [list $clone .. Rename] + + + + + #obsolete? + #upvar ::p::${clone_ID}:: clone_INFO + #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. + #upvar ::p::${OID}:: INFO + + + array set clone_INFO [array get INFO] + + array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' + + + #!review! + #if {![catch {set itemCmd $IFACE(m-1,name,item)}]} { + #puts "***************" + #puts "clone" + #parray IFINFO + #puts "***************" + #} + + #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern + + + #clone's interface maps must be a superset of original's + foreach lev {0 1} { + #set parent_ifaces [lindex $map 1 $lev] + set parent_ifaces [dict get $MAP interfaces level$lev] + + #set existing_ifaces [lindex $CLONEMAP 1 $lev] + set existing_ifaces [dict get $CLONEMAP interfaces level$lev] + + set added_ifaces_$lev [list] + foreach ifid $parent_ifaces { + if {$ifid ni $existing_ifaces} { + + #interface must not remain extensible after cloning. + if {[set ::p::${ifid}::_iface::o_open]} { + ::p::predator::compile_interface $ifid $_ID_ + set ::p::${ifid}::_iface::o_open 0 + } + + + + lappend added_ifaces_$lev $ifid + #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. + set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone + } + } + set extracted_sub_dict [dict get $CLONEMAP interfaces] + dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]] + dict set CLONEMAP interfaces $extracted_sub_dict + #lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]] + } + + #interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE) + + + #foreach *added* level0 interface.. + foreach ifid $added_ifaces_0 { + namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown + + + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + if {[dict exists $pdef default]} { + set varspace [dict get $pdef varspace] + if {$varspace eq ""} { + set ns ::p::${clone_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${clone_ID}::$varspace + } + } + + if {![info exists ${ns}::o_$prop]} { + #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) + set ${ns}::o_$prop [dict get $pdef default] + } + } + + #! May be replaced by method of same name + if {[namespace which ::p::${clone_ID}::$prop] eq ""} { + interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop + } + interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop + interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop + } + + #variables + dict for {vname vdef} $o_variables { + if {[dict exists $vdef default]} { + set varspace [dict get $vdef varspace] + if {$varspace eq ""} { + set ns ::p::${clone_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${clone_ID}::$varspace + } + } + if {![info exists ${ns}::$vname]} { + set ::p::${clone_ID}::$vname [dict get $vdef default] + } + } + } + + + #update the clone object's base interface to reflect the new methods. + #upvar 0 ::p::${ifid}:: IFACE + #set methods [list] + #foreach {key mname} [array get IFACE m-1,name,*] { + # set method [lindex [split $key ,] end] + # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP + # lappend methods $method + #} + #namespace eval ::p::${clone_ID} [list namespace export {*}$methods] + + + foreach method [dict keys $o_methods] { + + set arglist [dict get $o_methods $method arglist] + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method + + + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #proc calls the method in the interface - which is an interp alias to the head of the implementation chain + proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${ifid}::_iface::$method \$_ID_ $argvals + }] + + } + #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods] + + + if {[info exists o_unknown]} { + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown + interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + + #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown] + #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown] + + } + + + #2021 + #Consider >parent with constructor that sets height + #.eg >parent .. Constructor height { + # set o_height $height + #} + #>parent .. Create >child 5 + # - >child has height 5 + # now when we peform a clone operation - it is the >parent's constructor that will run. + # A clone will get default property and var values - but not other variable values unless the constructor sets them. + #>child .. Clone >fakesibling 6 + # - >sibling has height 6 + # Consider if >child had it's own constructor created with .. Construct prior to the clone operation. + # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead. + # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining... + # when we now do >sibling .. Create >grandchild + # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild + # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.) + # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild + #(though other arguments can be manually passed) + # #!review - does this make sense? What if we add + # + #constructor for each interface called after properties initialised. + #run each interface's constructor against child object, using the args passed into this clone method. + if {[llength [set constructordef [set o_constructor]]]} { + #error + puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID" + ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args + + } + + } + + + return $clone + +} + + + +interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?) +dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}} +proc ::p::-1::Constructor {_ID_ arglist body} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #set iid_top [::p::get_new_object_id] + + #the >interface constructor takes a list of IDs for o_usedby + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + + #::p::predator::remap $invocant + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] + set headid [expr {$maxversion + 1}] + set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 + + set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] + + #set varspaces [::pattern::varspace_list] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] + set body $varDecls\n[dict get $processed body] + #puts stderr "\t runtime_vardecls in Constructor $varDecls" + } + + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #puts stderr ---- + #puts stderr $body + #puts stderr ---- + + proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body + interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid + + + + set o_constructor [list $arglist $body] + set o_open 1 + + return +} + + + +dict set ::p::-1::_iface::o_methods UsedBy {arglist {}} +proc ::p::-1::UsedBy {_ID_} { + return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby] +} + + +dict set ::p::-1::_iface::o_methods Ready {arglist {}} +proc ::p::-1::Ready {_ID_} { + return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}] +} + + + +dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}} + +#'force' 1 indicates object command & variable will also be removed. +#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var. +#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4) +# +proc ::p::-1::Destroy {_ID_ {force 1}} { + #puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]" + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + + if {$OID eq "null"} { + puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" + return + } + + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout + + #explicit Destroy - remove traces + #puts ">>TRACES: [trace info variable $cmd]" + #foreach tinfo [trace info variable $cmd] { + # trace remove variable $cmd {*}$tinfo + #} + #foreach tinfo [trace info command $cmd] { + # trace remove command $cmd {*}$tinfo + #} + + + set _cmd [string map {::> ::} $cmd] + + #set ifaces [lindex $map 1] + set iface_stacks [dict get $MAP interfaces level0] + #set patterns [lindex $map 2] + set pattern_stacks [dict get $MAP interfaces level1] + + + + set ifaces $iface_stacks + + + set patterns $pattern_stacks + + + #set i 0 + #foreach iflist $ifaces { + # set IFID$i [lindex $iflist 0] + # incr i + #} + + + set IFTOP [lindex $ifaces end] + + set DESTRUCTOR ::p::${IFTOP}::___system___destructor + #may be a proc, or may be an alias + if {[namespace which $DESTRUCTOR] ne ""} { + set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] + + if {[catch {$DESTRUCTOR $temp_ID_} prob]} { + #!todo - ensure correct calling order of interfaces referencing the destructor proc + + + #!todo - emit destructor errors somewhere - logger? + #puts stderr "underlying proc already removed??? ---> $prob" + #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" + #puts stderr $::errorInfo + #puts stderr "---------------------" + } + } + + + #remove ourself from each interfaces list of referencers + #puts stderr "--- $ifaces" + + foreach var {ifaces patterns} { + + foreach i [set $var] { + + if {[string length $i]} { + if {$i == 2} { + #skip the >ifinfo interface which doesn't maintain a usedby list anyway. + continue + } + + if {[catch { + + upvar #0 ::p::${i}::_iface::o_usedby usedby + + array unset usedby i$OID + + + #puts "\n***>>***" + #puts "IFACE: $i usedby: $usedby" + #puts "***>>***\n" + + #remove interface if no more referencers + if {![array size usedby]} { + #puts " **************** DESTROYING unused interface $i *****" + #catch {namespace delete ::p::$i} + + #we happen to know where 'interface' object commands are kept: + + ::p::ifaces::>$i .. Destroy + + } + + } errMsg]} { + #warning + puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" + } + } + + } + + } + + set ns ::p::${OID} + #puts "-- destroying objects below namespace:'$ns'" + ::p::internals::DestroyObjectsBelowNamespace $ns + #puts "--.destroyed objects below '$ns'" + + + #set ns ::p::${OID}::_sub + #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace + #( ::p::OBJECT::$OID ) + #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" + #::p::internals::DestroyObjectsBelowNamespace $ns + + #same for _meta objects (e.g Methods,Properties collections) + #set ns ::p::${OID}::_meta + #::p::internals::DestroyObjectsBelowNamespace $ns + + + + #foreach obj [info commands ${ns}::>*] { + # #Assume it's one of ours, and ask it to die. + # catch {::p::meta::Destroy $obj} + # #catch {$cmd .. Destroy} + #} + #just in case the user created subnamespaces.. kill objects there too. + #foreach sub [namespace children $ns] { + # ::p::internals::DestroyObjectsBelowNamespace $sub + #} + + + #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value! + #use info commands ::p::${OID}::_ref::* to find all references - including variables never set + #remove variable traces on REF vars + #foreach rv [info vars ::p::${OID}::_ref::*] { + # foreach tinfo [trace info variable $rv] { + # #puts "-->removing traces on $rv: $tinfo" + # trace remove variable $rv {*}$tinfo + # } + #} + + #!todo - write tests + #refs create aliases and variables at the same place + #- but variable may not exist if it was never set e.g if it was only used with info exists + foreach rv [info commands ::p::${OID}::_ref::*] { + foreach tinfo [trace info variable $rv] { + #puts "-->removing traces on $rv: $tinfo" + trace remove variable $rv {*}$tinfo + } + } + + + + + + + + #if {[catch {namespace delete $nsMeta} msg]} { + # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " + #} else { + # #puts stderr "------ -- -- -- -- deleted $nsMeta " + #} + + + #!todo - remove + #temp + #catch {interp alias "" ::>$OID ""} + + if {$force} { + #rename $cmd {} + + #removing the alias will remove the command - even if it's been renamed + interp alias {} $alias {} + + #if {[catch {rename $_cmd {} } why]} { + # #!todo - work out why some objects don't have matching command. + # #puts stderr "\t rename $_cmd {} failed" + #} else { + # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" + #} + + } + + set refns ::p::${OID}::_ref + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- matching command: [llength [info commands ${refns}]]" + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" + + + #foreach v [info vars ${refns}::*] { + # unset $v + #} + #foreach p [info procs ${refns}::*] { + # rename $p {} + #} + #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { + # interp alias {} $a {} + #} + + + #set ts1 [clock seconds] + #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- exact command: [info commands ${refns}]" + + + + + #puts "--delete ::p::${OID}::_ref" + if {[namespace exists ::p::${OID}::_ref]} { + #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. + namespace delete ::p::${OID}::_ref:: + } + set ts2 [clock seconds] + #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" + + + #delete namespace where instance variables reside + #catch {namespace delete ::p::$OID} + namespace delete ::p::$OID + + #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout + return +} + + +interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility + + +dict set ::p::-1::_iface::o_methods Destructor {arglist {args}} +#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction? +#install a Destructor on the invocant's open level1 interface. +proc ::p::-1::Destructor {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + #lassign [lindex $map 0] OID alias itemCmd cmd + + set patterns [dict get $MAP interfaces level1] + + if {[llength $args] > 2} { + error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" + } + + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + error "NOT TESTED" + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + #::p::predator::remap $invocant + } + + + set ::p::${IID}::_iface::o_destructor_body [lindex $args end] + + if {[llength $args] > 1} { + #!todo - allow destructor args(?) + set arglist [lindex $args 0] + } else { + set arglist [list] + } + + set ::p::${IID}::_iface::o_destructor_args $arglist + + return +} + + + + + +interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit) + + +dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}} +proc ::p::-1::PatternMethod {_ID_ method arglist body} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + + namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 + + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + #puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls" + set body $varDecls\n[dict get $processed body] + #puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls" + } + + + set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist] + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] + #puts "\t\t--------------------" + #puts "\n" + #puts $body + #puts "\n" + #puts "\t\t--------------------" + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + + + #pointer from method-name to head of the interface's command-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + + if {$method in [dict keys $o_methods]} { + #error "patternmethod '$method' already present in interface $IID" + set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)" + if {[string match "*@next@*" $body]} { + append msg "\n EXTRA-WARNING: method contains @next@" + } + + puts stdout $msg + } else { + dict set o_methods $method [list arglist $arglist] + } + + #::p::-1::update_invocant_aliases $_ID_ + return +} + +#MultiMethod +#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants +# e.g1 $obj .. MultiMethod add {these 2} $arglist $body +# e.g2 $obj .. MultiMethod add {these n} $arglist $body +# +# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body +# +# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature. +# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature) +# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces) +# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? +# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed? +# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? +# (and how would we define the call order? - presumably as it appears in the conglomerate) +# (or could that be done with a more general method-wrapping mechanism?) +#...should multimethods use some sort of event mechanism, and/or message-passing system? +# +dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}} +proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { + set invocants [dict get $_ID_ i] + + error "not implemented" +} + +dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} +# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- ) +#we can create a method named "." by using the argprotect operator -- +# e.g >x .. Method -- . {args} $body +#It can then be called like so: >x . . +#This is not guaranteed to work and is not in the test suite +#for now we'll just use a highly unlikely string to indicate no argument was supplied +proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + if {$methodname eq $non_argument_magicstring} { + return $default_method + } else { + set extracted_value [dict get $MAP invocantdata] + lset extracted_value 2 $methodname + dict set MAP invocantdata $extracted_value ;#write modified value back + #update the object's command alias to match + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] + + #! $object_command was initially created as the renamed alias - so we have to do it again + rename $alias $object_command + trace add command $object_command rename [list $object_command .. Rename] + return $methodname + } +} + +dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} +proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set extracted_patterndata [dict get $MAP patterndata] + set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] + if {$methodname eq $non_argument_magicstring} { + return $pattern_default_method + } else { + dict set extracted_patterndata patterndefaultmethod $methodname + dict set MAP patterndata $extracted_patterndata + return $methodname + } +} + + +dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}} +proc ::p::-1::Method {_ID_ method arglist bodydef args} { + set invocants [dict get $_ID_ i] + + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + set invocant_signature [list] ; + ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. + foreach role [lsort [dict keys $invocants]] { + lappend invocant_signature $role [llength [dict get $invocants $role]] + } + #note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this') + + + + lassign [dict get $MAP invocantdata] OID alias default_method object_command + set interfaces [dict get $MAP interfaces level0] + + + + ################################################################################# + if 0 { + set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface + set prev_open [set ::p::${iid_top}::_iface::o_open] + + set iface ::p::ifaces::>$iid_top + + set f_new 0 + if {![string length $iid_top]} { + set f_new 1 + } else { + if {[$iface . isClosed]} { + set f_new 1 + } + } + if {$f_new} { + #create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + + } + set IID $iid_top + + } + ################################################################################# + + set IID [::p::predator::get_possibly_new_open_interface $OID] + + #upvar 0 ::p::${IID}:: IFACE + + namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces + + + #Interface proc + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 + + if {$method ni [dict keys $o_methods]} { + dict set o_methods $method [list arglist $arglist] + } + + #next_script will call to lower interface in iStack if we are $method.1 + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_ + #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<" + + + #implement + #----------------------------------- + set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + set varDecls "" + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + } + + + set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist] + + + + + + + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #if {[string length $varDecls]} { + # puts stdout "\t---------------------------------------------------------------" + # puts stdout "\t----- efficiency warning - implicit var declarations used -----" + # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" + # puts stdout "\t[string map [list \n \t\t\n] $body]" + # puts stdout "\t--------------------------" + #} + #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role + # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. + #(as specified by the @ operator during object conglomeration) + #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] + + #puts stdout "\t\t----------------------------" + #puts stdout "$body" + #puts stdout "\t\t----------------------------" + + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + #----------------------------------- + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + #point to the interface command only. The dispatcher will supply the invocant data + #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IID}::_iface::$method \$_ID_ $argvals + }] + + + if 0 { + if {[llength $argvals]} { + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { + apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ + }] + } else { + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { + apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ + }] + + } + } + + + #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + # ::p::${IID}::_iface::$method \$_ID_ $argvals + #}] + + #todo - for o_varspaces + #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method + #- this should work correctly with the 'uplevel 1' procs in the interfaces + + + if {[string length $o_varspace]} { + if {[string match "::*" $o_varspace]} { + namespace eval $o_varspace {} + } else { + namespace eval ::p::${OID}::$o_varspace {} + } + } + + + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + set colMethods ::p::${OID}::_meta::>colMethods + + if {[namespace which $colMethods] ne ""} { + if {![$colMethods . hasKey $method]} { + $colMethods . add [::p::internals::predator $_ID_ . $method .] $method + } + } + + #::p::-1::update_invocant_aliases $_ID_ + return + #::>pattern .. Create [::>pattern .. Namespace]::>method_??? + #return $method_object +} + + +dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}} +proc ::p::-1::V {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + + + set vlist [list] + foreach IID $ifaces { + dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { + if {[string match $glob $vname]} { + lappend vlist $vname + } + } + } + + + return $vlist +} + +#experiment from http://wiki.tcl.tk/4884 +proc p::predator::pipeline {args} { + set lambda {return -level 0} + foreach arg $args { + set lambda [list apply [dict get { + toupper {{lambda input} {string toupper [{*}$lambda $input]}} + tolower {{lambda input} {string tolower [{*}$lambda $input]}} + totitle {{lambda input} {string totitle [{*}$lambda $input]}} + prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}} + suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}} + } [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]] + } + return $lambda +} + +proc ::p::predator::get_apply_arg_0_oid {} { + set apply_args [lrange [info level 0] 2 end] + puts stderr ">>>>> apply_args:'$apply_args'<<<<" + set invocant [lindex $apply_args 0] + return [lindex [dict get $invocant i this] 0 0] +} +proc ::p::predator::get_oid {} { + #puts stderr "---->> [info level 1] <<-----" + set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 + tailcall lindex [dict get $_ID_ i this] 0 0 +} + +#todo - make sure this is called for all script installations - e.g propertyread etc etc +#Add tests to check code runs in correct namespace +#review - how does 'Varspace' command affect this? +proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} { + #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) + set arglist_apply "" + append arglist_apply "\$_ID_ " + foreach a $arglist { + if {$a eq "args"} { + append arglist_apply "{*}\$args" + } else { + append arglist_apply "\$[lindex $a 0] " + } + } + #!todo - allow fully qualified varspaces + if {[string length $varspace]} { + if {[string match ::* $varspace]} { + return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply" + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n" + return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply" + } + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" + #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" + + set script "tailcall apply \[list \{_ID_" + + if {[llength $arglist]} { + append script " $arglist" + } + append script "\} \{" + append script $body + append script "\} ::p::@OID@\] " + append script $arglist_apply + #puts stderr "\n88888888888888888888888888\n\t$script\n" + #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" + #return $script + + + #----------------------------------------------------------------------------- + # 2018 candidates + # + #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + + + #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) + #faster though. + #return "uplevel 1 \{$body\}" + return "uplevel 1 [list $body]" + #----------------------------------------------------------------------------- + + + + + #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" + #return "uplevel 1 \{$script\}" + + #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + + + + #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong + + #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns + + + #experiment with different dispatch mechanism (interp alias with 'namespace inscope') + #----------- + #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" + + + #return "uplevel 1 \{$body\}" ;#do nothing + + #---------- + + #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) + + #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body + + #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker + + #return "tailcall " + + + } +} + + +#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies. +#expand 'var' statements inline in method bodies +#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements. +# +#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces +#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches! +# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements. +#Think of var & varspace statments as a form of compile-time 'macro' +# +#caters for 2-element lists as arguments to var statement to allow 'aliasing' +#e.g var o_thing {o_data mydata} +# this will upvar o_thing as o_thing & o_data as mydata +# +proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { + set body {} + + #keep count of any explicit var statments per varspace in 'numDeclared' array + # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements. + + #default varspace is "" + #varspace should only have leading :: if it is an absolute namespace path. + + + foreach ln [split $rawbody \n] { + set trimline [string trim $ln] + + if {$trimline eq "var"} { + #plain var statement alone indicates we don't have any explicit declarations in this branch + # and we don't want implicit declarations for the current varspace either. + #!todo - implement test + + incr numDeclared($varspace) + + #may be further var statements e.g - in other code branches + #return [list body $rawbody varspaces_with_explicit_vars 1] + } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { + + #append body " upvar #0 " + #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " + #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " + + if {$varspace eq ""} { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " + } else { + if {[string match "::*" $varspace]} { + append body " namespace upvar $varspace " + } else { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " + } + } + + #any whitespace before or betw var names doesn't matter - about to use as list. + foreach varspec [string range $trimline 4 end] { + lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. + ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " + #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " + + append body "$var $alias " + + } + append body \n + + incr numDeclared($varspace) + } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { + #2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? + #it is assumed there is a single word following the 'varspace' keyword. + set varspace [string trim [string range $trimline 9 end]] + + if {$varspace in [list {{}} {""}]} { + set varspace "" + } + if {[string length $varspace]} { + #set varspace ::${varspace}:: + #no need to initialize numDeclared($varspace) incr will work anyway. + #if {![info exists numDeclared($varspace)]} { + # set numDeclared($varspace) 0 + #} + + if {[string match "::*" $varspace]} { + append body "namespace eval $varspace {} \n" + } else { + append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n" + } + + #puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} " + #append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n" + #append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n" + + #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n" + } + #!review - why? why do we need the magic 'default' name instead of just using the empty string? + #if varspace argument was empty string - leave it alone + } else { + append body $ln\n + } + } + + + + set varspaces [array names numDeclared] + return [list body $body varspaces_with_explicit_vars $varspaces] +} + + + + +#Interface Variables +dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} +proc ::p::-1::IV {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + + #!todo - test + #return [dict keys ::p::${OID}::_iface::o_variables $glob] + + set members [list] + foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { + if {[string match $glob $vname]} { + lappend members $vname + } + } + return $members +} + + +dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}} +proc ::p::-1::Methods {_ID_ {idx ""}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set col ::p::${OID}::_meta::>colMethods + + if {[namespace which $col] eq ""} { + patternlib::>collection .. Create $col + foreach IID $ifaces { + foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { + if {![$col . hasIndex $m]} { + #todo - create some sort of lazy-evaluating method object? + #set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist] + $col . add [::p::internals::predator $_ID_ . $m .] $m + } + } + } + } + + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } +} + +dict set ::p::-1::_iface::o_methods M {arglist {}} +proc ::p::-1::M {_ID_} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set members [list] + foreach IID $ifaces { + foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { + lappend members $m + } + } + return $members +} + + +#review +#Interface Methods +dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}} +proc ::p::-1::IM {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] + +} + + + +dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}} +proc ::p::-1::InterfaceStacks {_ID_} { + upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP + return [dict get $MAP interfaces level0] +} + + +dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}} +proc ::p::-1::PatternStacks {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + return [dict get $MAP interfaces level1] +} + + +#!todo fix. need to account for references which were never set to a value +dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}} +proc ::p::-1::DeletePropertyReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + set refvars [info vars ::p::${OID}::_ref::*] + #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. + foreach rv $refvars { + foreach tinfo [trace info variable $rv] { + set ops {}; set cmd {} + lassign $tinfo ops cmd + trace remove variable $rv $ops $cmd + } + unset $rv + lappend cleared_references $rv + } + + + return [list deleted_property_references $cleared_references] +} + +dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}} +proc ::p::-1::DeleteMethodReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + + set iflist [dict get $MAP interfaces level0] + set iflist_reverse [lreferse $iflist] + #set iflist [dict get $MAP interfaces level0] + + + set refcommands [info commands ::p::${OID}::_ref::*] + foreach c $refcommands { + set reftail [namespace tail $c] + set field [lindex [split $c +] 0] + set field_is_a_method 0 + foreach IFID $iflist_reverse { + if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { + set field_is_a_method 1 + break + } + } + if {$field_is_a_method} { + #what if it's also a property? + interp alias {} $c {} + lappend cleared_references $c + } + } + + + return [list deleted_method_references $cleared_references] +} + + +dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}} +proc ::p::-1::DeleteReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method this + + set result [dict create] + dict set result {*}[$this .. DeletePropertyReferences] + dict set result {*}[$this .. DeleteMethodReferences] + + return $result +} + +## +#Digest +# +#!todo - review +# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!) +# +#!todo - write tests - check that digest changes when properties of contained objects change value +# +#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method? +# +dict set ::p::-1::_iface::o_methods Digest {arglist {args}} +proc ::p::-1::Digest {_ID_ args} { + set invocants [dict get $_ID_ i] + # md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway. + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] _OID alias default_method this + + + set interface_ids [dict get $MAP interfaces level0] + set IFID0 [lindex $interface_ids end] + + set known_flags {-recursive -algorithm -a -indent} + set defaults {-recursive 1 -algorithm md5 -indent ""} + if {[dict exists $args -a] && ![dict exists $args -algorithm]} { + dict set args -algorithm [dict get $args -a] + } + + set opts [dict merge $defaults $args] + foreach key [dict keys $opts] { + if {$key ni $known_flags} { + error "unknown option $key. Expected only: $known_flags" + } + } + + + set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256} + if {[dict get $opts -algorithm] ni $known_algos} { + error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos" + } + set algo [string tolower [dict get $opts -algorithm]] + + # append comma for each var so that all changes in adjacent vars detectable. + # i.e set x 34; set y 5 + # must be distinguishable from: + # set x 3; set y 45 + + if {[dict get $opts -indent] ne ""} { + set state "" + set indent "[dict get $opts -indent]" + } else { + set state "---\n" + set indent " " + } + append state "${indent}object_command: $this\n" + set indent "${indent} " + + #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state. + append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state. + + + + + #!todo - recurse into 'varspaces' + set varspaces_found [list] + append state "${indent}interfaces:\n" + foreach IID $interface_ids { + append state "${indent} - interface: $IID\n" + namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces + append state "${indent} varspaces:\n" + foreach vs $local_o_varspaces { + if {$vs ni $varspaces_found} { + lappend varspaces_found $vs + append state "${indent} - varspace: $vs\n" + } + } + } + + append state "${indent}vars:\n" + foreach var [info vars ::p::${OID}::*] { + append state "${indent} - [namespace tail $var] : \"" + if {[catch {append state "[set $var]"}]} { + append state "[array get $var]" + } + append state "\"\n" + } + + if {[dict get $opts -recursive]} { + append state "${indent}sub-objects:\n" + set subargs $args + dict set subargs -indent "$indent " + foreach obj [info commands ::p::${OID}::>*] { + append state "[$obj .. Digest {*}$subargs]\n" + } + + append state "${indent}sub-namespaces:\n" + set subargs $args + dict set subargs -indent "$indent " + foreach ns [namespace children ::p::${OID}] { + append state "${indent} - namespace: $ns\n" + foreach obj [info commands ${ns}::>*] { + append state "[$obj .. Digest {*}$subargs]\n" + } + } + } + + + if {$algo in {"" raw none}} { + return $state + } else { + if {$algo eq "md5"} { + package require md5 + return [::md5::md5 -hex $state] + } elseif {$algo eq "sha256"} { + package require sha256 + return [::sha2::sha256 -hex $state] + } elseif {$algo eq "blowfish"} { + package require patterncipher + patterncipher::>blowfish .. Create >b1 + set [>b1 . key .] 12341234 + >b1 . encrypt $state -final 1 + set result [>b1 . ciphertext] + >b1 .. Destroy + + } elseif {$algo eq "blowfish-binary"} { + + } else { + error "can't get here" + } + + } +} + + +dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}} +proc ::p::-1::Variable {_ID_ varname args} { + set invocants [dict get $_ID_ i] + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + #this interface itself is always a co-invocant + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set interfaces [dict get $MAP interfaces level0] + + #set existing_IID [lindex $map 1 0 end] + set existing_IID [lindex $interfaces end] + + set prev_openstate [set ::p::${existing_IID}::_iface::o_open] + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #IID changed + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + + #update original object command + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_openstate + } + + set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface) + + if {[llength $args]} { + #!assume var not already present on interface - it is an error to define twice (?) + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + + + #Implement if there is a default + #!todo - correct behaviour when overlaying on existing object with existing var of this name? + #if {[string length $varspace]} { + # set ::p::${OID}::${varspace}::$varname [lindex $args 0] + #} else { + set ::p::${OID}::$varname [lindex $args 0] + #} + } else { + #lappend ::p::${IID}::_iface::o_variables [list $varname] + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } + + #varspace '_iface' + + return +} + + +#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility + +dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}} +proc ::p::-1::PatternVariable {_ID_ varname args} { + set invocants [dict get $_ID_ i] + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + ##this interface itself is always a co-invocant + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top + + set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. + + + if {[llength $args]} { + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + } else { + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } + + return +} + +dict set ::p::-1::_iface::o_methods Varspaces {arglist args} +proc ::p::-1::Varspaces {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + if {![llength $args]} { + #query + set iid_top [lindex [dict get $MAP interfaces level0] end] + set iface ::p::ifaces::>$iid_top + if {![string length $iid_top]} { + error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " + } elseif {[$iface . isClosed]} { + error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " + } + return [set ::p::${iid_top}::_iface::o_varspaces] + } + set IID [::p::predator::get_possibly_new_open_interface $OID] + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + + set varspaces $args + foreach vs $varspaces { + if {[string length $vs] && ($vs ni $o_varspaces)} { + if {[string match ::* $vs} { + namespace eval $vs {} + } else { + namespace eval ::p::${OID}::$vs {} + } + lappend o_varspaces $vs + } + } + return $o_varspaces +} + +#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface +dict set ::p::-1::_iface::o_methods Varspace {arglist args} +# set the default varspace for the interface, so that new methods/properties refer to it. +# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. +proc ::p::-1::Varspace {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + if {![llength $args]} { + #query + set iid_top [lindex [dict get $MAP interfaces level0] end] + set iface ::p::ifaces::>$iid_top + if {![string length $iid_top]} { + error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " + } elseif {[$iface . isClosed]} { + error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " + } + return [set ::p::${iid_top}::_iface::o_varspace] + } + set varspace [lindex $args 0] + + #set interfaces [dict get $MAP interfaces level0] + #set iid_top [lindex $interfaces end] + + set IID [::p::predator::get_possibly_new_open_interface $OID] + + + #namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + + if {[string length $varspace]} { + #ensure namespace exists !? do after list test? + if {[string match ::* $varspace]} { + namespace eval $varspace {} + } else { + namespace eval ::p::${OID}::$varspace {} + } + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + set o_varspace $varspace +} + + +proc ::p::predator::get_possibly_new_open_interface {OID} { + #we need to re-upvar MAP rather than using a parameter - as we need to write back to it + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #puts stderr ">>>>creating new interface $iid_top" + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + + return $iid_top +} + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}} +# set the default varspace for the interface, so that new methods/properties refer to it. +# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. +proc ::p::-1::PatternVarspace {_ID_ varspace args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + if {[string length $varspace]} { + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + #o_varspace is the currently active varspace + set o_varspace $varspace + +} +################################################################################################################################################### + +#get varspace and default from highest interface - return all interface ids which define it +dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}} +proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + + array set propinfo {} + set found_property_names [list] + #start at the lowest and work up (normal storage order of $interfaces) + foreach iid $interfaces { + set propinfodict [set ::p::${iid}::_iface::o_properties] + set matching_propnames [dict keys $propinfodict $propnamepattern] + foreach propname $matching_propnames { + if {$propname ni $found_property_names} { + lappend found_property_names $propname + } + lappend propinfo($propname,interfaces) $iid + ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one + if {[dict exists $propinfodict $propname default]} { + set propinfo($propname,default) [dict get $propinfodict $propname default] + } + set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] + } + } + + set resultdict [dict create] + foreach propname $found_property_names { + set fields [list varspace $propinfo($propname,varspace)] + if {[array exists propinfo($propname,default)]} { + lappend fields default [set propinfo($propname,default)] + } + lappend fields interfaces $propinfo($propname,interfaces) + dict set resultdict $propname $fields + } + return $resultdict +} + + +dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args} +proc ::p::-1::GetTopPattern {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level1] + set iid_top [lindex $interfaces end] + if {![string length $iid_top]} { + lassign [dict get $MAP invocantdata] OID _alias _default_method object_command + error "No installed level1 interfaces (patterns) for object $object_command" + } + return ::p::ifaces::>$iid_top +} + + + +dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args} +proc ::p::-1::GetTopInterface {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set iid_top [lindex [dict get $MAP interfaces level0] end] + if {![string length $iid_top]} { + lassign [dict get $MAP invocantdata] OID _alias _default_method object_command + error "No installed level0 interfaces for object $object_command" + } + return ::p::ifaces::>$iid_top +} + + +dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} +proc ::p::-1::GetExpandableInterface {_ID_ args} { + +} + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods Property {arglist {property args}} +proc ::p::-1::Property {_ID_ property args} { + #puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args" + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + if {[llength $args] > 1} { + error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)" + } + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + + set prev_openstate [set ::p::${iid_top}::_iface::o_open] + + set iface ::p::ifaces::>$iid_top + + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + + namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + + + if {$headid == 1} { + #implementation + #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property + + #if {$o_varspace eq ""} { + # set ns ::p::${OID} + #} else { + # if {[string match "::*" $o_varspace]} { + # set ns $o_varspace + # } else { + # set ns ::p::${OID}::$o_varspace + # } + #} + #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]] + + proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]] + + + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property + proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] + + + #chainhead pointers + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 + + + } + + if {($property ni [dict keys $o_methods])} { + interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property + } + + + + #installation on object + + #namespace eval ::p::${OID} [list namespace export $property] + + + + #obsolete? + #if {$property ni [P $_ID_]} { + #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces + #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant + #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant + #} + + #link main (GET)/(SET) to this interface + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property + interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property + + #Only install property if no method of same name already installed here. + #(Method takes precedence over property because property always accessible via 'set' reference) + #convenience pointer to chainhead pointer. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } else { + #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed + + + } + + + set varspace [set ::p::${IID}::_iface::o_varspace] + + + + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} + dict set o_variables o_$property [list varspace $varspace] + + + + + if {[llength $args]} { + #should store default once only! + #set IFINFO(v,default,o_$property) $default + + set default [lindex $args end] + + dict set o_properties $property [list default $default varspace $varspace] + + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { + # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] + #} else { + # lappend o_properties [list $property $default] + #} + + if {$varspace eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${OID}::$o_varspace + } + } + + set ${ns}::o_$property $default + #set ::p::${OID}::o_$property $default + } else { + + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { + # set o_properties [lreplace $o_properties $posn $posn [list $property]] + #} else { + # lappend o_properties [list $property] + #} + dict set o_properties $property [list varspace $varspace] + + + #variable ::p::${OID}::o_$property + } + + + + + + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) + #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} + + set colProperties ::p::${OID}::_meta::>colProperties + if {[namespace which $colProperties] ne ""} { + if {![$colProperties . hasKey $property]} { + $colProperties . add [::p::internals::predator $_ID_ . $property .] $property + } + } + + return +} +################################################################################################################################################### + + + +################################################################################################################################################### + +################################################################################################################################################### +interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility +dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}} +proc ::p::-1::PatternProperty {_ID_ property args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + + + + if {$headid == 1} { + #implementation + #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property + proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]] + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property + proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] + + + #chainhead pointers + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 + + } + + if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} { + interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property + } + + set varspace [set ::p::${IID}::_iface::o_varspace] + + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} + dict set o_variables o_$property [list varspace $varspace] + + set argc [llength $args] + + if {$argc} { + if {$argc == 1} { + set default [lindex $args 0] + dict set o_properties $property [list default $default varspace $varspace] + } else { + #if more than one arg - treat as a dict of options. + if {[dict exists $args -default]} { + set default [dict get $args -default] + dict set o_properties $property [list default $default varspace $varspace] + } else { + #no default value + dict set o_properties $property [list varspace $varspace] + } + } + #! only set default for property... not underlying variable. + #lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]] + } else { + dict set o_properties $property [list varspace $varspace] + } + return +} +################################################################################################################################################### + + + + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}} +proc ::p::-1::PatternPropertyRead {_ID_ property args} { + set invocants [dict get $_ID_ i] + + set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' + set OID [lindex $this_invocant 0] + #set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias defaut_command cmd + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + if {$headid == 1} { + set headid 2 ;#reserve 1 for the getprop of the underlying property + } + + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ + + + #implement + #----------------------------------- + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + #implementation + if {![llength $idxlist]} { + proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body + } else { + #what are we trying to achieve here? .. + proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body + } + + + #----------------------------------- + + + #adjust chain-head pointer to point to new head. + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + return +} +################################################################################################################################################### + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}} +proc ::p::-1::PropertyRead {_ID_ property args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead) + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] + + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd] + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + if {$headid == 1} { + set headid 2 + } + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself) + + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body + + #----------------------------------- + + + + #pointer from prop-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } +} +################################################################################################################################################### + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}} +proc ::p::-1::PropertyWrite {_ID_ property argname body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. + + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + #pw short for propertywrite + #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] + + + set maxversion [::p::predator::method_chainhead $IID (SET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (SET)$property.$headid + + set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body + + #----------------------------------- + + + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid +} +################################################################################################################################################### + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}} +proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set existing_ifaces [lindex $map 1 1] + set posn [lsearch $existing_ifaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] + + #set ::p::${IID}::_iface::o_open 0 + } else { + } + + #pw short for propertywrite + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + + + + + return + +} +################################################################################################################################################### + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}} +proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers + #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #note $arraykeypattern actually contains the name of the argument + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern _dontcare_ ;# + } + proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body + + #----------------------------------- + + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid + +} +################################################################################################################################################### + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}} +proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #set ::p::${IID}::_iface::o_open 0 + } + + + upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + return +} +################################################################################################################################################### + + + +#lappend ::p::-1::_iface::o_methods Implements +#!todo - some way to force overriding of any abstract (empty) methods from the source object +#e.g leave interface open and raise an error when closing it if there are unoverridden methods? + + + + + +#implementation reuse - sugar for >object .. Clone >target +dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}} +proc ::p::-1::Extends {_ID_ pattern} { + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'Extends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Clone $object_command + +} +#implementation reuse - sugar for >pattern .. Create >target +dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}} +proc ::p::-1::PatternExtends {_ID_ pattern} { + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'PatternExtends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Create $object_command +} + + +dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}} +proc ::p::-1::Extend {_ID_ {idx ""}} { + puts stderr "Extend is DEPRECATED - use Expand instead" + tailcall ::p::-1::Expand $_ID_ $idx +} + +#set the topmost interface on the iStack to be 'open' +dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}} +proc ::p::-1::Expand {_ID_ {idx ""}} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set iid_top [lindex $interfaces end] + set iface ::p::ifaces::>$iid_top + + if {![string length $iid_top]} { + #no existing interface - create a new one + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [list $iid_top] + dict set MAP interfaces $extracted_sub_dict ;#write new interface into map + $iface . open + return $iid_top + } else { + if {[$iface . isOpen]} { + #already open.. + #assume ready to expand.. shared or not! + return $iid_top + } + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {[$iface . refCount] > 1} { + if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} { + #!warning! not exercised by test suites! + + #remove ourself from the usedby list of the previous interface + array unset ::p::${iid_top}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + #remove existing interface & add + set posn [lsearch $interfaces $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + + set iid_top $IID + set iface ::p::ifaces::>$iid_top + } + } + } + + $iface . open + return $iid_top +} + +dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}} +proc ::p::-1::PatternExtend {_ID_ {idx ""}} { + puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead" + tailcall ::p::-1::PatternExpand $_ID_ $idx +} + + + +#set the topmost interface on the pStack to be 'open' if it's not shared +# if shared - 'copylink' to new interface before opening for extension +dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}} +proc ::p::-1::PatternExpand {_ID_ {idx ""}} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + #puts stderr "no tests written for PatternExpand " + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces + set iid_top [lindex $ifaces end] + set iface ::p::ifaces::>$iid_top + + if {![string length $iid_top]} { + #no existing interface - create a new one + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [list $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [list $iid_top] + $iface . open + return $iid_top + } else { + if {[$iface . isOpen]} { + #already open.. + #assume ready to expand.. shared or not! + return $iid_top + } + + if {[$iface . refCount] > 1} { + if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} { + #!WARNING! not exercised by test suite! + #remove ourself from the usedby list of the previous interface + array unset ::p::${iid_top}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $ifaces $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID] + + set iid_top $IID + set iface ::p::ifaces::>$iid_top + } + } + } + + $iface . open + return $iid_top +} + + + + + +dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}} +proc ::p::-1::Properties {_ID_ {idx ""}} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set col ::p::${OID}::_meta::>colProperties + + if {[namespace which $col] eq ""} { + patternlib::>collection .. Create $col + foreach IID $ifaces { + dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] { + if {![$col . hasIndex $prop]} { + $col . add [::p::internals::predator $_ID_ . $prop .] $prop + } + } + } + } + + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } +} + +dict set ::p::-1::_iface::o_methods P {arglist {}} +proc ::p::-1::P {_ID_} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set members [list] + foreach IID $interfaces { + foreach prop [dict keys [set ::p::${IID}::_iface::o_properties]] { + lappend members $prop + } + } + return [lsort $members] + +} +#Interface Properties +dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}} +proc ::p::-1::IP {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set members [list] + + foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { + if {[string match $glob [lindex $m 0]]} { + lappend members [lindex $m 0] + } + } + return $members +} + + +#used by rename.test - theoretically should be on a separate interface! +dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}} +proc ::p::-1::CheckInvocants {_ID_ args} { + #check all invocants in the _ID_ are consistent with data stored in their MAP variable + set status "ok" ;#default to optimistic assumption + set problems [list] + + set invocant_dict [dict get $_ID_ i] + set invocant_roles [dict keys $invocant_dict] + + foreach role $invocant_roles { + set invocant_list [dict get $invocant_dict $role] + foreach aliased_invocantdata $invocant_list { + set OID [lindex $aliased_invocantdata 0] + set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] + #we use lrange to make sure the lists are in canonical form + if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { + set status "not-ok" + lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] + } + } + + } + + + set result [dict create] + dict set result status $status + dict set result problems $problems + + return $result +} + + +#get or set t +dict set ::p::-1::_iface::o_methods Namespace {arglist {args}} +proc ::p::-1::Namespace {_ID_ args} { + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set IID [lindex [dict get $MAP interfaces level0] end] + + namespace upvar ::p::${IID}::_iface o_varspace active_varspace + + if {[string length $active_varspace]} { + set ns ::p::${OID}::$active_varspace + } else { + set ns ::p::${OID} + } + + #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object? + # - should .. Namespace be usable at all from outside the object? + + + if {[llength $args]} { + #special case some of the namespace subcommands. + + #delete + if {[string match "d*" [lindex $args 0]]} { + error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object." + } + #upvar,ensemble,which,code,origin,expor,import,forget + if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} { + return [namespace eval $ns [list namespace {*}$args]] + } + #current + if {[string match "cu*" [lindex $args 0]]} { + return $ns + } + + #children,eval,exists,inscope,parent,qualifiers,tail + return [namespace {*}[linsert $args 1 $ns]] + } else { + return $ns + } +} + + + + + + + + + + +dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}} +proc ::p::-1::PatternUnknown {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + #::p::predator::remap $invocant + } + + set handlermethod [lindex $args 0] + + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } + +} + + + +dict set ::p::-1::_iface::o_methods Unknown {arglist {args}} +proc ::p::-1::Unknown {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + set prev_open [set ::p::${existing_IID}::_iface::o_open] + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_open + } + + set handlermethod [lindex $args 0] + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + #set ::p::${IID}::(unknown) $handlermethod + + + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod + interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod + + #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod] + #namespace eval ::p::${OID} [list namespace unknown $handlermethod] + + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } + +} + + +#useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []' +# should also work for non-object results +dict set ::p::-1::_iface::o_methods As {arglist {varname}} +proc ::p::-1::As {_ID_ varname} { + set invocants [dict get $_ID_ i] + #puts stdout "invocants: $invocants" + #!todo - handle multiple invocants with other roles, not just 'this' + + set OID [lindex [dict get $_ID_ i this] 0 0] + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + tailcall set $varname $cmd + } else { + #puts stdout "info level 1 [info level 1]" + set role_members [dict get $_ID_ i this] + if {[llength $role_members] == 1} { + set member [lindex $role_members 0] + lassign $member _OID namespace default_method stackvalue _wrapped + tailcall set $varname $stackvalue + } else { + #multiple invocants - return all results as a list + set resultlist [list] + foreach member $role_members { + lassign $member _OID namespace default_method stackvalue _wrapped + lappend resultlist $stackvalue + } + tailcall set $varname $resultlist + } + } +} + +#!todo - AsFileStream ?? +dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}} +proc ::p::-1::AsFile {_ID_ filename args} { + dict set default -force 0 + dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object + set opts [dict merge $default $args] + set force [dict get $opts -force] + set dumpmethod [dict get $opts -dumpmethod] + + + if {[file pathtype $filename] eq "relative"} { + set filename [pwd]/$filename + } + set filedir [file dirname $filename] + if {![sf::file_writable $filedir]} { + error "(method AsFile) ERROR folder $filedir is not writable" + } + if {[file exists $filename]} { + if {!$force} { + error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite" + } + if {![sf::file_writable $filename]} { + error "(method AsFile) ERROR file $filename is not writable - check permissions" + } + } + set fd [open $filename w] + fconfigure $fd -translation binary + + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + #tailcall set $varname $cmd + set object_data [$cmd {*}$dumpmethod] + puts -nonewline $fd $object_data + close $fd + return [list status 1 bytes [string length $object_data] filename $filename] + } else { + #puts stdout "info level 1 [info level 1]" + set role_members [dict get $_ID_ i this] + if {[llength $role_members] == 1} { + set member [lindex $role_members 0] + lassign $member _OID namespace default_method stackvalue _wrapped + puts -nonewline $fd $stackvalue + close $fd + #tailcall set $varname $stackvalue + return [list status 1 bytes [string length $stackvalue] filename $filename] + } else { + #multiple invocants - return all results as a list + set resultlist [list] + foreach member $role_members { + lassign $member _OID namespace default_method stackvalue _wrapped + lappend resultlist $stackvalue + } + puts -nonewline $fd $resultset + close $fd + return [list status 1 bytes [string length $resultset] filename $filename] + #tailcall set $varname $resultlist + } + } + +} + + + +dict set ::p::-1::_iface::o_methods Object {arglist {}} +proc ::p::-1::Object {_ID_} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + set result [string map [list ::> ::] $cmd] + if {![catch {info level -1} prev_level]} { + set called_by "(called by: $prev_level)" + } else { + set called_by "(called by: interp?)" + + } + + puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" + puts stdout " (returning $result)" + + return $result +} + +#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname +dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} +proc ::p::-1::MakeAlias {_ID_cmdname } { + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + error "concept probably won't work - try making dispatcher understand trailing '= cmdname' " +} +dict set ::p::-1::_iface::o_methods ID {arglist {}} +proc ::p::-1::ID {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + return $OID +} + +dict set ::p::-1::_iface::o_methods IFINFO {arglist {}} +proc ::p::-1::IFINFO {_ID_} { + puts stderr "--_ID_: $_ID_--" + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + + puts stderr "-- MAP: $MAP--" + + set interfaces [dict get $MAP interfaces level0] + set IFID [lindex $interfaces 0] + + if {![llength $interfaces]} { + puts stderr "No interfaces present at level 0" + } else { + foreach IFID $interfaces { + set iface ::p::ifaces::>$IFID + puts stderr "$iface : [$iface --]" + puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" + set variables [set ::p::${IFID}::_iface::o_variables] + puts stderr "\tvariables: $variables" + } + } + +} + + + + +dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} +proc ::p::-1::INVOCANTDATA {_ID_} { + #same as a call to: >object .. + return $_ID_ +} + +#obsolete? +dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}} +proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} { + set updated_ID_ $_ID_ + array set updated_roles [list] + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + foreach role $invocant_roles { + + set role_members [dict get $invocants $role] + foreach member [dict get $invocants $role] { + #each member is a 2-element list consisting of the OID and a dictionary + #each member is a 5-element list + #set OID [lindex $member 0] + #set object_dict [lindex $member 1] + lassign $member OID alias itemcmd cmd wrapped + + set MAP [set ::p::${OID}::_meta::map] + #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} + + if {[dict get $MAP invocantdata] eq $member} + #same - nothing to do + + } else { + package require overtype + puts stderr "---------------------------------------------------------" + puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" + set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] + puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" + puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" + puts stderr "---------------------------------------------------------" + #take _meta::map version + lappend updated_roles($role) [dict get $MAP invocantdata] + } + + } + + #overwrite changed roles only + foreach role [array names updated_roles] { + dict set updated_ID_ i $role [set updated_roles($role)] + } + + return $updated_ID_ +} + + + +dict set ::p::-1::_iface::o_methods INFO {arglist {}} +proc ::p::-1::INFO {_ID_} { + set result "" + append result "_ID_: $_ID_\n" + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + append result "invocant roles: $invocant_roles\n" + set total_invocants 0 + foreach key $invocant_roles { + incr total_invocants [llength [dict get $invocants $key]] + } + + append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" + foreach key $invocant_roles { + append result "\t-------------------------------\n" + append result "\trole: $key\n" + set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants + append result "\t Raw data for this role: $role_members\n" + append result "\t Number of invocants in this role: [llength $role_members]\n" + foreach member $role_members { + #set OID [lindex [dict get $invocants $key] 0 0] + set OID [lindex $member 0] + append result "\t\tOID: $OID\n" + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + append result "\t\tmap:\n" + foreach key [dict keys $MAP] { + append result "\t\t\t$key\n" + append result "\t\t\t\t [dict get $MAP $key]\n" + append result "\t\t\t----\n" + } + lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped + append result "\t\tNamespace: $namespace\n" + append result "\t\tDefault method: $default_method\n" + append result "\t\tCommand: $cmd\n" + append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n" + append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n" + append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n" + } else { + lassign $member _OID namespace default_method stackvalue _wrapped + append result "\t\t last item on the predator stack is a value not an object" + append result "\t\t Value is: $stackvalue" + + } + } + append result "\n" + append result "\t-------------------------------\n" + } + + + + return $result +} + + + + +dict set ::p::-1::_iface::o_methods Rename {arglist {args}} +proc ::p::-1::Rename {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + if {![llength $args]} { + error "Rename expected \$newname argument" + } + + #Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant? + upvar #0 ::p::${OID}::_meta::map MAP + + + + #puts ">>.>> Rename. _ID_: $_ID_" + + if {[catch { + + if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { + + #appears to be a 'trace command rename' firing + #puts "\t>>>> rename trace fired $MAP $args <<<" + + lassign $args oldcmd newcmd + set extracted_invocantdata [dict get $MAP invocantdata] + lset extracted_invocantdata 3 $newcmd + dict set MAP invocantdata $extracted_invocantdata + + + lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped + + #Write the same info into the _ID_ value of the alias + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] + + + + #! $object_command was initially created as the renamed alias - so we have to do it again + uplevel 1 [list rename $alias $object_command] + trace add command $object_command rename [list $object_command .. Rename] + + } elseif {[llength $args] == 1} { + #let the rename trace fire and we will be called again to do the remap! + uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] + } else { + error "Rename expected \$newname argument ." + } + + } errM]} { + puts stderr "\t@@@@@@ rename error" + set ruler "\t[string repeat - 80]" + puts stderr $ruler + puts stderr $errM + puts stderr $ruler + + } + + return + + +} + +proc ::p::obj_get_invocants {_ID_} { + return [dict get $_ID_ i] +} +#The invocant role 'this' is special and should always have only one member. +# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX +proc ::p::obj_get_this_oid {_ID_} { + return [lindex [dict get $_ID_ i this] 0 0] +} +proc ::p::obj_get_this_ns {_ID_} { + return [lindex [dict get $_ID_ i this] 0 1] +} + +proc ::p::obj_get_this_cmd {_ID_} { + return [lindex [dict get $_ID_ i this] 0 3] +} +proc ::p::obj_get_this_data {_ID_} { + lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd + #set this_invocant_data {*}[dict get $_ID_ i this] + return [list oid $OID ns $ns cmd $cmd] +} +proc ::p::map {OID varname} { + tailcall upvar #0 ::p::${OID}::_meta::map $varname +} + + + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm index 4107b8af..ca061a7c 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm @@ -1,645 +1,645 @@ -package provide patterncmd [namespace eval patterncmd { - variable version - - set version 1.2.4 -}] - - -namespace eval pattern { - variable idCounter 1 ;#used by pattern::uniqueKey - - namespace eval cmd { - namespace eval util { - package require overtype - variable colwidths_lib [dict create] - variable colwidths_lib_default 15 - - dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] - dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] - dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] - dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] - - proc colhead {type args} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname [string totitle $colname] {*}$args]" - } - return $line - } - proc colbreak {type} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" - } - return $line - } - proc col {type col val args} { - # args -head bool -tail bool ? - #---------------------------------------------------------------------------- - set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] - dict set default -backchar "" - dict set default -headchar "" - dict set default -tailchar "" - dict set default -headoverridechar "" - dict set default -tailoverridechar "" - dict set default -justify "left" - if {([llength $args] % 2) != 0} { - error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " - } - foreach {k v} $args { - if {$k ni $known_opts} { - error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" - } - } - set opts [dict merge $default $args] - set backchar [dict get $opts -backchar] - set headchar [dict get $opts -headchar] - set tailchar [dict get $opts -tailchar] - set headoverridechar [dict get $opts -headoverridechar] - set tailoverridechar [dict get $opts -tailoverridechar] - set justify [dict get $opts -justify] - #---------------------------------------------------------------------------- - - - - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - #calculate headwidths - set headwidth 0 - set tailwidth 0 - foreach {key def} $colwidths { - set thisheadlen [string length [dict get $def head]] - if {$thisheadlen > $headwidth} { - set headwidth $thisheadlen - } - set thistaillen [string length [dict get $def tail]] - if {$thistaillen > $tailwidth} { - set tailwidth $thistaillen - } - } - - - set spec [dict get $colwidths $col] - if {[string length $backchar]} { - set ch $backchar - } else { - set ch [dict get $spec ch] - } - set num [dict get $spec num] - set headchar [dict get $spec head] - set tailchar [dict get $spec tail] - - if {[string length $headchar]} { - set headchar $headchar - } - if {[string length $tailchar]} { - set tailchar $tailchar - } - #overrides only apply if the head/tail has a length - if {[string length $headchar]} { - if {[string length $headoverridechar]} { - set headchar $headoverridechar - } - } - if {[string length $tailchar]} { - if {[string length $tailoverridechar]} { - set tailchar $tailoverridechar - } - } - set head [string repeat $headchar $headwidth] - set tail [string repeat $tailchar $tailwidth] - - set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] - if {$justify eq "left"} { - set left_done [overtype::left $base "$head$val"] - return [overtype::right $left_done "$tail"] - } elseif {$justify in {centre center}} { - set mid_done [overtype::centre $base $val] - set left_mid_done [overtype::left $mid_done $head] - return [overtype::right $left_mid_done $tail] - } else { - set right_done [overtype::right $base "$val$tail"] - return [overtype::left $right_done $head] - } - - } - - } - } - -} - -#package require pattern - -proc ::pattern::libs {} { - set libs [list \ - pattern {-type core -note "alternative:pattern2"}\ - pattern2 {-type core -note "alternative:pattern"}\ - patterncmd {-type core}\ - metaface {-type core}\ - patternpredator2 {-type core}\ - patterndispatcher {-type core}\ - patternlib {-type core}\ - patterncipher {-type optional -note optional}\ - ] - - - - package require overtype - set result "" - - append result "[cmd::util::colbreak lib]\n" - append result "[cmd::util::colhead lib -justify centre]\n" - append result "[cmd::util::colbreak lib]\n" - foreach libname [dict keys $libs] { - set libinfo [dict get $libs $libname] - - append result [cmd::util::col lib library $libname] - if {[catch [list package present $libname] ver]} { - append result [cmd::util::col lib version "N/A"] - } else { - append result [cmd::util::col lib version $ver] - } - append result [cmd::util::col lib type [dict get $libinfo -type]] - - if {[dict exists $libinfo -note]} { - set note [dict get $libinfo -note] - } else { - set note "" - } - append result [cmd::util::col lib note $note] - append result "\n" - } - append result "[cmd::util::colbreak lib]\n" - return $result -} - -proc ::pattern::record {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply { - {index rec args} - { - if {[llength $args] == 0} { - return [lindex $rec $index] - } - if {[llength $args] == 1} { - return [lreplace $rec $index $index [lindex $args 0]] - } - error "Invalid number of arguments." - } - - }] - - set map {} - foreach field $fields { - dict set map $field [linsert $accessor end [incr index]] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} -proc ::pattern::record2 {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply] - - set template { - {rec args} - { - if {[llength $args] == 0} { - return [lindex $rec %idx%] - } - if {[llength $args] == 1} { - return [lreplace $rec %idx% %idx% [lindex $args 0]] - } - error "Invalid number of arguments." - } - } - - set map {} - foreach field $fields { - set body [string map [list %idx% [incr index]] $template] - dict set map $field [list ::apply $body] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} - -proc ::argstest {args} { - package require cmdline - -} - -proc ::pattern::objects {} { - set result [::list] - - foreach ns [namespace children ::pp] { - #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] - set ch [namespace tail $ns] - if {[string range $ch 0 2] eq "Obj"} { - set OID [string range $ch 3 end] ;#OID need not be digits (!?) - lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] - } - } - - - - - return $result -} - - - -proc ::pattern::name {num} { - #!todo - fix - #set ::p::${num}::(self) - - lassign [interp alias {} ::p::$num] _predator info - if {![string length $_predator$info]} { - error "No object found for num:$num (no interp alias for ::p::$num)" - } - set invocants [dict get $info i] - set invocants_with_role_this [dict get $invocants this] - set invocant_this [lindex $invocants_with_role_this 0] - - - #lassign $invocant_this id info - #set map [dict get $info map] - #set fields [lindex $map 0] - lassign $invocant_this _id _ns _defaultmethod name _etc - return $name -} - - -proc ::pattern::with {cmd script} { - foreach c [info commands ::p::-1::*] { - interp alias {} [namespace tail $c] {} $c $cmd - } - interp alias {} . {} $cmd . - interp alias {} .. {} $cmd .. - - return [uplevel 1 $script] -} - - - - - -#system diagnostics etc - -proc ::pattern::varspace_list {IID} { - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables - - set varspaces [list] - dict for {vname vdef} $o_variables { - set vs [dict get $vdef varspace] - if {$vs ni $varspaces} { - lappend varspaces $vs - } - } - if {$o_varspace ni $varspaces} { - lappend varspaces $o_varspace - } - return $varspaces -} - -proc ::pattern::check_interfaces {} { - foreach ns [namespace children ::p] { - set IID [namespace tail $ns] - if {[string is digit $IID]} { - foreach ref [array names ${ns}::_iface::o_usedby] { - set OID [string range $ref 1 end] - if {![namespace exists ::p::${OID}::_iface]} { - puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" - } else { - puts -nonewline stdout . - } - - - #if {![info exists ::p::${OID}::(self)]} { - # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" - #} - } - } - } - puts -nonewline stdout "\r\n" -} - - -#from: http://wiki.tcl.tk/8766 (Introspection on aliases) -#usedby: metaface-1.1.6+ -#required because aliases can be renamed. -#A renamed alias will still return it's target with 'interp alias {} oldname' -# - so given newname - we require which_alias to return the same info. - proc ::pattern::which_alias {cmd} { - uplevel 1 [list ::trace add execution $cmd enterstep ::error] - catch {uplevel 1 $cmd} res - uplevel 1 [list ::trace remove execution $cmd enterstep ::error] - #puts stdout "which_alias $cmd returning '$res'" - return $res - } -# [info args] like proc following an alias recursivly until it reaches -# the proc it originates from or cannot determine it. -# accounts for default parameters set by interp alias -# - - - -proc ::pattern::aliasargs {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info args $cmd] - # strip off the interp set default args - return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } -proc ::pattern::aliasbody {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info body $cmd] - # strip off the interp set default args - return $result - #return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } - - - - - -proc ::pattern::uniqueKey2 {} { - #!todo - something else?? - return [clock seconds]-[incr ::pattern::idCounter] -} - -#used by patternlib package -proc ::pattern::uniqueKey {} { - return [incr ::pattern::idCounter] - #uuid with tcllibc is about 30us compared with 2us - # for large datasets, e.g about 100K inserts this would be pretty noticable! - #!todo - uuid pool with background thread to repopulate when idle? - #return [uuid::uuid generate] -} - - - -#------------------------------------------------------------------------------------------------------------------------- - -proc ::pattern::test1 {} { - set msg "OK" - - puts stderr "next line should say:'--- saystuff:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternMethod saystuff args { - puts stderr "--- saystuff: $args" - } - ::>thing .. Create ::>jjj - - ::>jjj . saystuff $msg - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test2 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternProperty stuff $msg - - ::>thing .. Create ::>jjj - - puts stderr "--- property 'stuff' value:[::>jjj . stuff]" - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test3 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. Property stuff $msg - - puts stderr "--- property 'stuff' value:[::>thing . stuff]" - ::>thing .. Destroy -} - -#--------------------------------- -#unknown/obsolete - - - - - - - - -#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} -if {0} { - proc ::p::internals::new_interface {{usedbylist {}}} { - set OID [incr ::p::ID] - ::p::internals::new_object ::p::ifaces::>$OID "" $OID - puts "obsolete >> new_interface created object $OID" - foreach usedby $usedbylist { - set ::p::${OID}::_iface::o_usedby(i$usedby) 1 - } - set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) - #NOTE - o_varspace is only the default varspace for when new methods/properties are added. - # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. - - set ::p::${OID}::_iface::o_constructor [list] - set ::p::${OID}::_iface::o_variables [list] - set ::p::${OID}::_iface::o_properties [dict create] - set ::p::${OID}::_iface::o_methods [dict create] - array set ::p::${OID}::_iface::o_definition [list] - set ::p::${OID}::_iface::o_open 1 ;#open for extending - return $OID - } - - - #temporary way to get OID - assumes single 'this' invocant - #!todo - make generic. - proc ::pattern::get_oid {_ID_} { - #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" - return [lindex [dict get $_ID_ i this] 0 0] - - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - #set role_members [dict get $invocants this] - ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. - #set this_invocant [lindex [dict get $_ID_ i this] 0] ; - #lassign $this_invocant OID this_info - # - #return $OID - } - - #compile the uncompiled level1 interface - #assert: no more than one uncompiled interface present at level1 - proc ::p::meta::PatternCompile {self} { - ???? - - upvar #0 $self SELFMAP - set ID [lindex $SELFMAP 0 0] - - set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces - - set iid -1 - foreach i $patterns { - if {[set ::p::${i}::_iface::o_open]} { - set iid $i ;#found it - break - } - } - - if {$iid > -1} { - #!todo - - ::p::compile_interface $iid - set ::p::${iid}::_iface::o_open 0 - } else { - #no uncompiled interface present at level 1. Do nothing. - return - } - } - - - proc ::p::meta::Def {self} { - error ::p::meta::Def - - upvar #0 $self SELFMAP - set self_ID [lindex $SELFMAP 0 0] - set IFID [lindex $SELFMAP 1 0 end] - - set maxc1 0 - set maxc2 0 - - set arrName ::p::${IFID}:: - - upvar #0 $arrName state - - array set methods {} - - foreach nm [array names state] { - if {[regexp {^m-1,name,(.+)} $nm _match mname]} { - set methods($mname) [set state($nm)] - - if {[string length $mname] > $maxc1} { - set maxc1 [string length $mname] - } - if {[string length [set state($nm)]] > $maxc2} { - set maxc2 [string length [set state($nm)]] - } - } - } - set bg1 [string repeat " " [expr {$maxc1 + 2}]] - set bg2 [string repeat " " [expr {$maxc2 + 2}]] - - - set r {} - foreach nm [lsort -dictionary [array names methods]] { - set arglist $state(m-1,args,$nm) - append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" - } - return $r - } - - - +package provide patterncmd [namespace eval patterncmd { + variable version + + set version 1.2.4 +}] + + +namespace eval pattern { + variable idCounter 1 ;#used by pattern::uniqueKey + + namespace eval cmd { + namespace eval util { + package require overtype + variable colwidths_lib [dict create] + variable colwidths_lib_default 15 + + dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] + dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] + dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] + dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] + + proc colhead {type args} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname [string totitle $colname] {*}$args]" + } + return $line + } + proc colbreak {type} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" + } + return $line + } + proc col {type col val args} { + # args -head bool -tail bool ? + #---------------------------------------------------------------------------- + set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] + dict set default -backchar "" + dict set default -headchar "" + dict set default -tailchar "" + dict set default -headoverridechar "" + dict set default -tailoverridechar "" + dict set default -justify "left" + if {([llength $args] % 2) != 0} { + error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set backchar [dict get $opts -backchar] + set headchar [dict get $opts -headchar] + set tailchar [dict get $opts -tailchar] + set headoverridechar [dict get $opts -headoverridechar] + set tailoverridechar [dict get $opts -tailoverridechar] + set justify [dict get $opts -justify] + #---------------------------------------------------------------------------- + + + + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + #calculate headwidths + set headwidth 0 + set tailwidth 0 + foreach {key def} $colwidths { + set thisheadlen [string length [dict get $def head]] + if {$thisheadlen > $headwidth} { + set headwidth $thisheadlen + } + set thistaillen [string length [dict get $def tail]] + if {$thistaillen > $tailwidth} { + set tailwidth $thistaillen + } + } + + + set spec [dict get $colwidths $col] + if {[string length $backchar]} { + set ch $backchar + } else { + set ch [dict get $spec ch] + } + set num [dict get $spec num] + set headchar [dict get $spec head] + set tailchar [dict get $spec tail] + + if {[string length $headchar]} { + set headchar $headchar + } + if {[string length $tailchar]} { + set tailchar $tailchar + } + #overrides only apply if the head/tail has a length + if {[string length $headchar]} { + if {[string length $headoverridechar]} { + set headchar $headoverridechar + } + } + if {[string length $tailchar]} { + if {[string length $tailoverridechar]} { + set tailchar $tailoverridechar + } + } + set head [string repeat $headchar $headwidth] + set tail [string repeat $tailchar $tailwidth] + + set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] + if {$justify eq "left"} { + set left_done [overtype::left $base "$head$val"] + return [overtype::right $left_done "$tail"] + } elseif {$justify in {centre center}} { + set mid_done [overtype::centre $base $val] + set left_mid_done [overtype::left $mid_done $head] + return [overtype::right $left_mid_done $tail] + } else { + set right_done [overtype::right $base "$val$tail"] + return [overtype::left $right_done $head] + } + + } + + } + } + +} + +#package require pattern + +proc ::pattern::libs {} { + set libs [list \ + pattern {-type core -note "alternative:pattern2"}\ + pattern2 {-type core -note "alternative:pattern"}\ + patterncmd {-type core}\ + metaface {-type core}\ + patternpredator2 {-type core}\ + patterndispatcher {-type core}\ + patternlib {-type core}\ + patterncipher {-type optional -note optional}\ + ] + + + + package require overtype + set result "" + + append result "[cmd::util::colbreak lib]\n" + append result "[cmd::util::colhead lib -justify centre]\n" + append result "[cmd::util::colbreak lib]\n" + foreach libname [dict keys $libs] { + set libinfo [dict get $libs $libname] + + append result [cmd::util::col lib library $libname] + if {[catch [list package present $libname] ver]} { + append result [cmd::util::col lib version "N/A"] + } else { + append result [cmd::util::col lib version $ver] + } + append result [cmd::util::col lib type [dict get $libinfo -type]] + + if {[dict exists $libinfo -note]} { + set note [dict get $libinfo -note] + } else { + set note "" + } + append result [cmd::util::col lib note $note] + append result "\n" + } + append result "[cmd::util::colbreak lib]\n" + return $result +} + +proc ::pattern::record {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply { + {index rec args} + { + if {[llength $args] == 0} { + return [lindex $rec $index] + } + if {[llength $args] == 1} { + return [lreplace $rec $index $index [lindex $args 0]] + } + error "Invalid number of arguments." + } + + }] + + set map {} + foreach field $fields { + dict set map $field [linsert $accessor end [incr index]] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} +proc ::pattern::record2 {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply] + + set template { + {rec args} + { + if {[llength $args] == 0} { + return [lindex $rec %idx%] + } + if {[llength $args] == 1} { + return [lreplace $rec %idx% %idx% [lindex $args 0]] + } + error "Invalid number of arguments." + } + } + + set map {} + foreach field $fields { + set body [string map [list %idx% [incr index]] $template] + dict set map $field [list ::apply $body] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} + +proc ::argstest {args} { + package require cmdline + +} + +proc ::pattern::objects {} { + set result [::list] + + foreach ns [namespace children ::pp] { + #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] + set ch [namespace tail $ns] + if {[string range $ch 0 2] eq "Obj"} { + set OID [string range $ch 3 end] ;#OID need not be digits (!?) + lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] + } + } + + + + + return $result +} + + + +proc ::pattern::name {num} { + #!todo - fix + #set ::p::${num}::(self) + + lassign [interp alias {} ::p::$num] _predator info + if {![string length $_predator$info]} { + error "No object found for num:$num (no interp alias for ::p::$num)" + } + set invocants [dict get $info i] + set invocants_with_role_this [dict get $invocants this] + set invocant_this [lindex $invocants_with_role_this 0] + + + #lassign $invocant_this id info + #set map [dict get $info map] + #set fields [lindex $map 0] + lassign $invocant_this _id _ns _defaultmethod name _etc + return $name +} + + +proc ::pattern::with {cmd script} { + foreach c [info commands ::p::-1::*] { + interp alias {} [namespace tail $c] {} $c $cmd + } + interp alias {} . {} $cmd . + interp alias {} .. {} $cmd .. + + return [uplevel 1 $script] +} + + + + + +#system diagnostics etc + +proc ::pattern::varspace_list {IID} { + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables + + set varspaces [list] + dict for {vname vdef} $o_variables { + set vs [dict get $vdef varspace] + if {$vs ni $varspaces} { + lappend varspaces $vs + } + } + if {$o_varspace ni $varspaces} { + lappend varspaces $o_varspace + } + return $varspaces +} + +proc ::pattern::check_interfaces {} { + foreach ns [namespace children ::p] { + set IID [namespace tail $ns] + if {[string is digit $IID]} { + foreach ref [array names ${ns}::_iface::o_usedby] { + set OID [string range $ref 1 end] + if {![namespace exists ::p::${OID}::_iface]} { + puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" + } else { + puts -nonewline stdout . + } + + + #if {![info exists ::p::${OID}::(self)]} { + # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" + #} + } + } + } + puts -nonewline stdout "\r\n" +} + + +#from: http://wiki.tcl.tk/8766 (Introspection on aliases) +#usedby: metaface-1.1.6+ +#required because aliases can be renamed. +#A renamed alias will still return it's target with 'interp alias {} oldname' +# - so given newname - we require which_alias to return the same info. + proc ::pattern::which_alias {cmd} { + uplevel 1 [list ::trace add execution $cmd enterstep ::error] + catch {uplevel 1 $cmd} res + uplevel 1 [list ::trace remove execution $cmd enterstep ::error] + #puts stdout "which_alias $cmd returning '$res'" + return $res + } +# [info args] like proc following an alias recursivly until it reaches +# the proc it originates from or cannot determine it. +# accounts for default parameters set by interp alias +# + + + +proc ::pattern::aliasargs {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info args $cmd] + # strip off the interp set default args + return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } + } +proc ::pattern::aliasbody {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info body $cmd] + # strip off the interp set default args + return $result + #return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } + } + + + + + +proc ::pattern::uniqueKey2 {} { + #!todo - something else?? + return [clock seconds]-[incr ::pattern::idCounter] +} + +#used by patternlib package +proc ::pattern::uniqueKey {} { + return [incr ::pattern::idCounter] + #uuid with tcllibc is about 30us compared with 2us + # for large datasets, e.g about 100K inserts this would be pretty noticable! + #!todo - uuid pool with background thread to repopulate when idle? + #return [uuid::uuid generate] +} + + + +#------------------------------------------------------------------------------------------------------------------------- + +proc ::pattern::test1 {} { + set msg "OK" + + puts stderr "next line should say:'--- saystuff:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternMethod saystuff args { + puts stderr "--- saystuff: $args" + } + ::>thing .. Create ::>jjj + + ::>jjj . saystuff $msg + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test2 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternProperty stuff $msg + + ::>thing .. Create ::>jjj + + puts stderr "--- property 'stuff' value:[::>jjj . stuff]" + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test3 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. Property stuff $msg + + puts stderr "--- property 'stuff' value:[::>thing . stuff]" + ::>thing .. Destroy +} + +#--------------------------------- +#unknown/obsolete + + + + + + + + +#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} +if {0} { + proc ::p::internals::new_interface {{usedbylist {}}} { + set OID [incr ::p::ID] + ::p::internals::new_object ::p::ifaces::>$OID "" $OID + puts "obsolete >> new_interface created object $OID" + foreach usedby $usedbylist { + set ::p::${OID}::_iface::o_usedby(i$usedby) 1 + } + set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) + #NOTE - o_varspace is only the default varspace for when new methods/properties are added. + # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. + + set ::p::${OID}::_iface::o_constructor [list] + set ::p::${OID}::_iface::o_variables [list] + set ::p::${OID}::_iface::o_properties [dict create] + set ::p::${OID}::_iface::o_methods [dict create] + array set ::p::${OID}::_iface::o_definition [list] + set ::p::${OID}::_iface::o_open 1 ;#open for extending + return $OID + } + + + #temporary way to get OID - assumes single 'this' invocant + #!todo - make generic. + proc ::pattern::get_oid {_ID_} { + #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" + return [lindex [dict get $_ID_ i this] 0 0] + + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + #set role_members [dict get $invocants this] + ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. + #set this_invocant [lindex [dict get $_ID_ i this] 0] ; + #lassign $this_invocant OID this_info + # + #return $OID + } + + #compile the uncompiled level1 interface + #assert: no more than one uncompiled interface present at level1 + proc ::p::meta::PatternCompile {self} { + ???? + + upvar #0 $self SELFMAP + set ID [lindex $SELFMAP 0 0] + + set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces + + set iid -1 + foreach i $patterns { + if {[set ::p::${i}::_iface::o_open]} { + set iid $i ;#found it + break + } + } + + if {$iid > -1} { + #!todo + + ::p::compile_interface $iid + set ::p::${iid}::_iface::o_open 0 + } else { + #no uncompiled interface present at level 1. Do nothing. + return + } + } + + + proc ::p::meta::Def {self} { + error ::p::meta::Def + + upvar #0 $self SELFMAP + set self_ID [lindex $SELFMAP 0 0] + set IFID [lindex $SELFMAP 1 0 end] + + set maxc1 0 + set maxc2 0 + + set arrName ::p::${IFID}:: + + upvar #0 $arrName state + + array set methods {} + + foreach nm [array names state] { + if {[regexp {^m-1,name,(.+)} $nm _match mname]} { + set methods($mname) [set state($nm)] + + if {[string length $mname] > $maxc1} { + set maxc1 [string length $mname] + } + if {[string length [set state($nm)]] > $maxc2} { + set maxc2 [string length [set state($nm)]] + } + } + } + set bg1 [string repeat " " [expr {$maxc1 + 2}]] + set bg2 [string repeat " " [expr {$maxc2 + 2}]] + + + set r {} + foreach nm [lsort -dictionary [array names methods]] { + set arglist $state(m-1,args,$nm) + append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" + } + return $r + } + + + } \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm index 457d5742..680ea88f 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm @@ -1,754 +1,754 @@ -package provide patternpredator2 1.2.4 - -proc ::p::internals::jaws {OID _ID_ args} { - #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" - #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - yield - set w 1 - - set stack [list] - set wordcount [llength $args] - set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first - set unsupported 0 - set operator "" - set operator_prev "" ;#used only by argprotect to revert to previous operator - - - if {$OID ne "null"} { - #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) - #upvar #0 ::p::${OID}::_meta::map MAP - set MAP [set ::p::${OID}::_meta::map] - } else { - # error "jaws - OID = 'null' ???" - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key - } - set invocantdata [dict get $MAP invocantdata] - lassign $invocantdata OID alias default_method object_command wrapped - - set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code - - #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w - while {$w < $wordcount} { - set word [lindex $args [expr {$w -1}]] - #puts stdout "w:$w word:$word stack:$stack" - - if {$operator eq "argprotect"} { - set operator $operator_prev - lappend stack $word - incr w - } else { - if {[llength $stack]} { - if {$word in $terminals} { - set reduction [list 0 $_ID_ {*}$stack ] - #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" - - - set _ID_ [yield $reduction] - set stack [list] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] - #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" - } - - #review - 2018. switched to _ID_ instead of MAP - lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command - #lassign [dict get $MAP invocantdata] OID alias default_method object_command - - - #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" - set operator $word - #don't incr w - #incr w - } else { - if {$operator eq "argprotect"} { - set operator $operator_prev - set operator_prev "" - lappend stack $word - } else { - #only look for leading argprotect chacter (-) if we're not already in argprotect mode - if {$word eq "--"} { - set operator_prev $operator - set operator "argprotect" - #Don't add the plain argprotector to the stack - } elseif {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set operator_prev $operator - set operator "argprotect" - lappend stack $word - } else { - lappend stack $word - } - } - - - incr w - } - } else { - #no stack - switch -- $word {.} { - - if {$OID ne "null"} { - #we know next word is a property or method of a pattern object - incr w - set nextword [lindex $args [expr {$w - 1}]] - set command ::p::${OID}::$nextword - set stack [list $command] ;#2018 j - set operator . - if {$w eq $wordcount} { - set finished_args 1 - } - } else { - # don't incr w - #set nextword [lindex $args [expr {$w - 1}]] - set command $object_command ;#taken from the MAP - set stack [list "_exec_" $command] - set operator . - } - - - } {..} { - incr w - set nextword [lindex $args [expr {$w -1}]] - set command ::p::-1::$nextword - #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. - set stack [list $command] ;#faster, and intent is clearer than lappend. - set operator .. - if {$w eq $wordcount} { - set finished_args 1 - } - } {,} { - #puts stdout "Stackless comma!" - - - if {$OID ne "null"} { - set command ::p::${OID}::$default_method - } else { - set command [list $default_method $object_command] - #object_command in this instance presumably be a list and $default_method a list operation - #e.g "lindex {A B C}" - } - #lappend stack $command - set stack [list $command] - set operator , - } {--} { - set operator_prev $operator - set operator argprotect - #no stack - - } {!} { - set command $object_command - set stack [list "_exec_" $object_command] - #puts stdout "!!!! !!!! $stack" - set operator ! - } default { - if {$operator eq ""} { - if {$OID ne "null"} { - set command ::p::${OID}::$default_method - } else { - set command [list $default_method $object_command] - } - set stack [list $command] - set operator , - lappend stack $word - } else { - #no stack - so we don't expect to be in argprotect mode already. - if {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set operator_prev $operator - set operator "argprotect" - lappend stack $word - } else { - lappend stack $word - } - - } - } - incr w - } - - } - } ;#end while - - #process final word outside of loop - #assert $w == $wordcount - #trailing operators or last argument - if {!$finished_args} { - set word [lindex $args [expr {$w -1}]] - if {$operator eq "argprotect"} { - set operator $operator_prev - set operator_prev "" - - lappend stack $word - incr w - } else { - - - switch -- $word {.} { - if {![llength $stack]} { - #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] - yieldto return [::p::internals::ref_to_object $_ID_] - error "assert: never gets here" - - } else { - #puts stdout "==== $stack" - #assert - whenever _ID_ changed in this proc - we have updated the $OID variable - yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] - error "assert: never gets here" - } - set operator . - - } {..} { - #trailing .. after chained call e.g >x . item 0 .. - #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" - #set reduction [list 0 $_ID_ {*}$stack] - yieldto return [yield [list 0 $_ID_ {*}$stack]] - } {#} { - set unsupported 1 - } {,} { - set unsupported 1 - } {&} { - set unsupported 1 - } {@} { - set unsupported 1 - } {--} { - - #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] - #puts stdout " -> -> -> about to call yield $reduction <- <- <-" - set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] - } - yieldto return $MAP - } {!} { - #error "untested branch" - set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] - } - lassign [dict get $MAP invocantdata] OID alias default_command object_command - set command $object_command - set stack [list "_exec_" $command] - set operator ! - } default { - if {$operator eq ""} { - #error "untested branch" - lassign [dict get $MAP invocantdata] OID alias default_command object_command - #set command ::p::${OID}::item - set command ::p::${OID}::$default_command - lappend stack $command - set operator , - - } - #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. - lappend stack $word - } - if {$unsupported} { - set unsupported 0 - error "trailing '$word' not supported" - - } - - #if {$operator eq ","} { - # incr wordcount 2 - # set stack [linsert $stack end-1 . item] - #} - incr w - } - } - - - #final = 1 - #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" - - return [list 1 $_ID_ {*}$stack] -} - - - -#trailing. directly after object -proc ::p::internals::ref_to_object {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_method object_command - set refname ::p::${OID}::_ref::__OBJECT - - array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces - - set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" - trace add variable $refname {read} $traceCmd - } - set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] - if {[list {array} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {array} $traceCmd - } - - set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] - if {[list {write} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {write} $traceCmd - } - - set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] - if {[list {unset} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {unset} $traceCmd - } - return $refname -} - - -proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { - #if {[lindex $fullstack 0] eq "_exec_"} { - # #strip it. This instruction isn't relevant for a reference. - # set commandstack [lrange $fullstack 1 end] - #} else { - # set commandstack $fullstack - #} - #set argstack [lassign $commandstack command] - #set field [string map {> __OBJECT_} [namespace tail $command]] - - - - set reftail [namespace tail $refname] - set argstack [lassign [split $reftail +] field] - set field [string map {> __OBJECT_} [namespace tail $command]] - - #puts stderr "refname:'$refname' command: $command field:$field" - - - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - } else { - #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] - } - lassign [dict get $MAP invocantdata] OID alias default_method object_command - - - - if {$OID ne "null"} { - interp alias {} $refname {} $command $_ID_ {*}$argstack - } else { - interp alias {} $refname {} $command {*}$argstack - } - - - #set iflist [lindex $map 1 0] - set iflist [dict get $MAP interfaces level0] - #set iflist [dict get $MAP interfaces level0] - set field_is_property_like 0 - foreach IFID [lreverse $iflist] { - #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. - if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { - set field_is_property_like 1 - #There is a setter or getter (but not necessarily an entry in the o_properties dict) - break - } - } - - - - - #whether field is a property or a method - remove any commandrefMisuse_TraceHandler - foreach tinfo [trace info variable $refname] { - #puts "-->removing traces on $refname: $tinfo" - if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { - trace remove variable $refname {*}$tinfo - } - } - - if {$field_is_property_like} { - #property reference - - - set this_invocantdata [lindex [dict get $_ID_ i this] 0] - lassign $this_invocantdata OID _alias _defaultmethod object_command - #get fully qualified varspace - - # - set propdict [$object_command .. GetPropertyInfo $field] - if {[dict exist $propdict $field]} { - set field_is_a_property 1 - set propinfo [dict get $propdict $field] - set varspace [dict get $propinfo varspace] - if {$varspace eq ""} { - set full_varspace ::p::${OID} - } else { - if {[::string match "::*" $varspace]} { - set full_varspace $varspace - } else { - set full_varspace ::p::${OID}::$varspace - } - } - } else { - set field_is_a_property 0 - #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property - #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) - set full_varspace ::p::${OID} - } - - - - - - #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) - set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] - if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { - trace add variable ${full_varspace}::o_${field} {write} $Hndlr - } - set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] - if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { - trace add variable ${full_varspace}::o_${field} {unset} $Hndlr - } - - - #supply all data in easy-access form so that propref_trace_read is not doing any extra work. - set get_cmd ::p::${OID}::(GET)$field - set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] - - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - set fieldvarname ${full_varspace}::o_${field} - - - #synch the refvar with the real var if it exists - #catch {set $refname [$refname]} - if {[array exists $fieldvarname]} { - if {![llength $argstack]} { - #unindexed reference - array set $refname [array get $fieldvarname] - #upvar $fieldvarname $refname - } else { - set s0 [lindex $argstack 0] - #refs to nonexistant array members common? (catch vs 'info exists') - if {[info exists ${fieldvarname}($s0)]} { - set $refname [set ${fieldvarname}($s0)] - } - } - } else { - #refs to uninitialised props actually should be *very* common. - #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. - #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. - - #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! - - #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" - - - if {![llength $argstack]} { - #catch {set $refname [set ::p::${OID}::o_$field]} - if {[info exists $fieldvarname]} { - set $refname [set $fieldvarname] - #upvar $fieldvarname $refname - } - } else { - if {[llength $argstack] == 1} { - #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} - if {[info exists $fieldvarname]} { - set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] - } - - } else { - #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} - if {[info exists $fieldvarname]} { - set $refname [lindex [set $fieldvarname] $argstack] - } - } - } - - #! what if someone has put a trace on ::errorInfo?? - #set ::errorInfo $errorInfo_prev - } - trace add variable $refname {read} $traceCmd - - set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] - trace add variable $refname {write} $traceCmd - - set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] - trace add variable $refname {unset} $traceCmd - - - set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] - # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" - trace add variable $refname {array} $traceCmd - } - - } else { - #puts "$refname ====> adding refMisuse_traceHandler $alias $field" - #matching variable in order to detect attempted use as property and throw error - - #2018 - #Note that we are adding a trace on a variable (the refname) which does not exist. - #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) - #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added - ##array set $refname {} ;#empty array - # - the empty array would mean a slightly better error message when misusing a command ref as an array - #but this seems like a code complication for little benefit - #review - - trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] - } -} - - - -#trailing. after command/property -proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { - if {[lindex $fullstack 0] eq "_exec_"} { - #strip it. This instruction isn't relevant for a reference. - set commandstack [lrange $fullstack 1 end] - } else { - set commandstack $fullstack - } - set argstack [lassign $commandstack command] - set field [string map {> __OBJECT_} [namespace tail $command]] - - - #!todo? - # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. - # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. - - - #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. - # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. - - - set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] - - if {[llength [info commands $refname]]} { - #todo - review - what if the field changed to/from a property/method? - #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs - return $refname - } - ::p::internals::create_or_update_reference $OID $_ID_ $refname $command - return $refname -} - - -namespace eval pp { - variable operators [list .. . -- - & @ # , !] - variable operators_notin_args "" - foreach op $operators { - append operators_notin_args "({$op} ni \$args) && " - } - set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands - #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} -} -interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! - - - - - -# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. -#each map is a 2 element list of lists. -# form: {$commandinfo $interfaceinfo} -# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} - -#2018 -#each map is a dict. -#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} - - -#OID = Object ID (integer for now - could in future be a uuid) -proc ::p::predator2 {_ID_ args} { - #puts stderr "predator2: _ID_:'$_ID_' args:'$args'" - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - - #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. - #set this_role_members [dict get $invocants this] - #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. - #lassign $this_invocant this_OID this_info_dict - - set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - - set cheat 1 ;# - #------- - #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) - #(it should be functionally equivalent to remove this shortcut block) - if {$cheat} { - if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { - - set remaining_args [lassign $args dot method_or_prop] - - #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? - set command ::p::${this_OID}::$method_or_prop - #REVIEW! - #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') - #if {[llength $command] > 1} { - # error "methods with spaces not included in test suites - todo fix!" - #} - #Dont use {*}$command - (so we can support methods with spaces) - #if {![llength [info commands $command]]} {} - if {[namespace which $command] eq ""} { - if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { - #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces - set command ::p::${this_OID}::(UNKNOWN) - #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" - } - } else { - #tailcall {*}$command $_ID_ {*}$remaining_args - tailcall $command $_ID_ {*}$remaining_args - } - } - } - #------------ - - - if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { - return $_ID_ - } - - - #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" - - - - #puts stderr "this_info_dict: $this_info_dict" - - - - - if {![llength $args]} { - #should return some sort of public info.. i.e probably not the ID which is an implementation detail - #return cmd - return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID - - #return a dict keyed on object command name - (suitable as use for a .. Create 'target') - #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped - #return [list $object_command [list -id $this_OID ]] - } elseif {[llength $args] == 1} { - #short-circuit the single index case for speed. - if {[lindex $args 0] ni {.. . -- - & @ # , !}} { - #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method - lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method - - tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] - } elseif {[lindex $args 0] eq {--}} { - - #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. - # - combined with using UUIDs for $OID, and a secured/removed metaface on the object - # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) - # - this could effectively hide the object's namespaces,vars etc from the caller (?) - return [set ::p::${this_OID}::_meta::map] - } - } - - - - #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) - #incr c - #set reduce ::p::reducer${this_OID}_$c - set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] - #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" - coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args - - - set current_ID_ $_ID_ - - set final 0 - set result "" - while {$final == 0} { - #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) - set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] - #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" - #if {[string match *Destroy $command]} { - # puts stdout " calling Destroy reduction_args:'$reduction_args'" - #} - if {$final == 1} { - - if {[llength $command] == 1} { - if {$command eq "_exec_"} { - tailcall {*}$reduction_args - } - if {[llength [info commands $command]]} { - tailcall {*}$command $current_ID_ {*}$reduction_args - } - set cmdname [namespace tail $command] - set this_OID [lindex [dict get $current_ID_ i this] 0 0] - if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { - lset command 0 ::p::${this_OID}::(UNKNOWN) - tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" - } - - } else { - #e.g lindex {a b c} - tailcall {*}$command {*}$reduction_args - } - - - } else { - if {[lindex $command 0] eq "_exec_"} { - set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] - - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] - } else { - if {[llength $command] == 1} { - if {![llength [info commands $command]]} { - set cmdname [namespace tail $command] - set this_OID [lindex [dict get $current_ID_ i this] 0 0] - if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { - - lset command 0 ::p::${this_OID}::(UNKNOWN) - set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" - } - } else { - #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] - set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] - - } - } else { - set result [uplevel 1 [list {*}$command {*}$reduction_args]] - } - - if {[llength [info commands $result]]} { - if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { - #looks like a pattern command - set current_ID_ [$result .. INVOCANTDATA] - - - #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA - #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { - # set current_ID_ $result_invocantdata - #} else { - # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" - #} - } else { - #non-pattern command - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] - } - } else { - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] - #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) - - } - } - - } - } - error "Assert: Shouldn't get here (end of ::p::predator2)" - #return $result -} +package provide patternpredator2 1.2.4 + +proc ::p::internals::jaws {OID _ID_ args} { + #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" + #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + yield + set w 1 + + set stack [list] + set wordcount [llength $args] + set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first + set unsupported 0 + set operator "" + set operator_prev "" ;#used only by argprotect to revert to previous operator + + + if {$OID ne "null"} { + #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) + #upvar #0 ::p::${OID}::_meta::map MAP + set MAP [set ::p::${OID}::_meta::map] + } else { + # error "jaws - OID = 'null' ???" + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key + } + set invocantdata [dict get $MAP invocantdata] + lassign $invocantdata OID alias default_method object_command wrapped + + set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code + + #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w + while {$w < $wordcount} { + set word [lindex $args [expr {$w -1}]] + #puts stdout "w:$w word:$word stack:$stack" + + if {$operator eq "argprotect"} { + set operator $operator_prev + lappend stack $word + incr w + } else { + if {[llength $stack]} { + if {$word in $terminals} { + set reduction [list 0 $_ID_ {*}$stack ] + #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" + + + set _ID_ [yield $reduction] + set stack [list] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] + #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" + } + + #review - 2018. switched to _ID_ instead of MAP + lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command + #lassign [dict get $MAP invocantdata] OID alias default_method object_command + + + #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" + set operator $word + #don't incr w + #incr w + } else { + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + lappend stack $word + } else { + #only look for leading argprotect chacter (-) if we're not already in argprotect mode + if {$word eq "--"} { + set operator_prev $operator + set operator "argprotect" + #Don't add the plain argprotector to the stack + } elseif {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + } + + + incr w + } + } else { + #no stack + switch -- $word {.} { + + if {$OID ne "null"} { + #we know next word is a property or method of a pattern object + incr w + set nextword [lindex $args [expr {$w - 1}]] + set command ::p::${OID}::$nextword + set stack [list $command] ;#2018 j + set operator . + if {$w eq $wordcount} { + set finished_args 1 + } + } else { + # don't incr w + #set nextword [lindex $args [expr {$w - 1}]] + set command $object_command ;#taken from the MAP + set stack [list "_exec_" $command] + set operator . + } + + + } {..} { + incr w + set nextword [lindex $args [expr {$w -1}]] + set command ::p::-1::$nextword + #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. + set stack [list $command] ;#faster, and intent is clearer than lappend. + set operator .. + if {$w eq $wordcount} { + set finished_args 1 + } + } {,} { + #puts stdout "Stackless comma!" + + + if {$OID ne "null"} { + set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + #object_command in this instance presumably be a list and $default_method a list operation + #e.g "lindex {A B C}" + } + #lappend stack $command + set stack [list $command] + set operator , + } {--} { + set operator_prev $operator + set operator argprotect + #no stack - + } {!} { + set command $object_command + set stack [list "_exec_" $object_command] + #puts stdout "!!!! !!!! $stack" + set operator ! + } default { + if {$operator eq ""} { + if {$OID ne "null"} { + set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + } + set stack [list $command] + set operator , + lappend stack $word + } else { + #no stack - so we don't expect to be in argprotect mode already. + if {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + + } + } + incr w + } + + } + } ;#end while + + #process final word outside of loop + #assert $w == $wordcount + #trailing operators or last argument + if {!$finished_args} { + set word [lindex $args [expr {$w -1}]] + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + + lappend stack $word + incr w + } else { + + + switch -- $word {.} { + if {![llength $stack]} { + #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] + yieldto return [::p::internals::ref_to_object $_ID_] + error "assert: never gets here" + + } else { + #puts stdout "==== $stack" + #assert - whenever _ID_ changed in this proc - we have updated the $OID variable + yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] + error "assert: never gets here" + } + set operator . + + } {..} { + #trailing .. after chained call e.g >x . item 0 .. + #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" + #set reduction [list 0 $_ID_ {*}$stack] + yieldto return [yield [list 0 $_ID_ {*}$stack]] + } {#} { + set unsupported 1 + } {,} { + set unsupported 1 + } {&} { + set unsupported 1 + } {@} { + set unsupported 1 + } {--} { + + #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] + #puts stdout " -> -> -> about to call yield $reduction <- <- <-" + set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] + } + yieldto return $MAP + } {!} { + #error "untested branch" + set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] + } + lassign [dict get $MAP invocantdata] OID alias default_command object_command + set command $object_command + set stack [list "_exec_" $command] + set operator ! + } default { + if {$operator eq ""} { + #error "untested branch" + lassign [dict get $MAP invocantdata] OID alias default_command object_command + #set command ::p::${OID}::item + set command ::p::${OID}::$default_command + lappend stack $command + set operator , + + } + #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. + lappend stack $word + } + if {$unsupported} { + set unsupported 0 + error "trailing '$word' not supported" + + } + + #if {$operator eq ","} { + # incr wordcount 2 + # set stack [linsert $stack end-1 . item] + #} + incr w + } + } + + + #final = 1 + #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" + + return [list 1 $_ID_ {*}$stack] +} + + + +#trailing. directly after object +proc ::p::internals::ref_to_object {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command + set refname ::p::${OID}::_ref::__OBJECT + + array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces + + set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" + trace add variable $refname {read} $traceCmd + } + set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] + if {[list {array} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {array} $traceCmd + } + + set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] + if {[list {write} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {write} $traceCmd + } + + set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] + if {[list {unset} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {unset} $traceCmd + } + return $refname +} + + +proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { + #if {[lindex $fullstack 0] eq "_exec_"} { + # #strip it. This instruction isn't relevant for a reference. + # set commandstack [lrange $fullstack 1 end] + #} else { + # set commandstack $fullstack + #} + #set argstack [lassign $commandstack command] + #set field [string map {> __OBJECT_} [namespace tail $command]] + + + + set reftail [namespace tail $refname] + set argstack [lassign [split $reftail +] field] + set field [string map {> __OBJECT_} [namespace tail $command]] + + #puts stderr "refname:'$refname' command: $command field:$field" + + + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + } else { + #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] + } + lassign [dict get $MAP invocantdata] OID alias default_method object_command + + + + if {$OID ne "null"} { + interp alias {} $refname {} $command $_ID_ {*}$argstack + } else { + interp alias {} $refname {} $command {*}$argstack + } + + + #set iflist [lindex $map 1 0] + set iflist [dict get $MAP interfaces level0] + #set iflist [dict get $MAP interfaces level0] + set field_is_property_like 0 + foreach IFID [lreverse $iflist] { + #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. + if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { + set field_is_property_like 1 + #There is a setter or getter (but not necessarily an entry in the o_properties dict) + break + } + } + + + + + #whether field is a property or a method - remove any commandrefMisuse_TraceHandler + foreach tinfo [trace info variable $refname] { + #puts "-->removing traces on $refname: $tinfo" + if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { + trace remove variable $refname {*}$tinfo + } + } + + if {$field_is_property_like} { + #property reference + + + set this_invocantdata [lindex [dict get $_ID_ i this] 0] + lassign $this_invocantdata OID _alias _defaultmethod object_command + #get fully qualified varspace + + # + set propdict [$object_command .. GetPropertyInfo $field] + if {[dict exist $propdict $field]} { + set field_is_a_property 1 + set propinfo [dict get $propdict $field] + set varspace [dict get $propinfo varspace] + if {$varspace eq ""} { + set full_varspace ::p::${OID} + } else { + if {[::string match "::*" $varspace]} { + set full_varspace $varspace + } else { + set full_varspace ::p::${OID}::$varspace + } + } + } else { + set field_is_a_property 0 + #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property + #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) + set full_varspace ::p::${OID} + } + + + + + + #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) + set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] + if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { + trace add variable ${full_varspace}::o_${field} {write} $Hndlr + } + set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] + if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { + trace add variable ${full_varspace}::o_${field} {unset} $Hndlr + } + + + #supply all data in easy-access form so that propref_trace_read is not doing any extra work. + set get_cmd ::p::${OID}::(GET)$field + set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] + + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + set fieldvarname ${full_varspace}::o_${field} + + + #synch the refvar with the real var if it exists + #catch {set $refname [$refname]} + if {[array exists $fieldvarname]} { + if {![llength $argstack]} { + #unindexed reference + array set $refname [array get $fieldvarname] + #upvar $fieldvarname $refname + } else { + set s0 [lindex $argstack 0] + #refs to nonexistant array members common? (catch vs 'info exists') + if {[info exists ${fieldvarname}($s0)]} { + set $refname [set ${fieldvarname}($s0)] + } + } + } else { + #refs to uninitialised props actually should be *very* common. + #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. + #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. + + #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! + + #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" + + + if {![llength $argstack]} { + #catch {set $refname [set ::p::${OID}::o_$field]} + if {[info exists $fieldvarname]} { + set $refname [set $fieldvarname] + #upvar $fieldvarname $refname + } + } else { + if {[llength $argstack] == 1} { + #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] + } + + } else { + #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] $argstack] + } + } + } + + #! what if someone has put a trace on ::errorInfo?? + #set ::errorInfo $errorInfo_prev + } + trace add variable $refname {read} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] + trace add variable $refname {write} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] + trace add variable $refname {unset} $traceCmd + + + set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] + # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" + trace add variable $refname {array} $traceCmd + } + + } else { + #puts "$refname ====> adding refMisuse_traceHandler $alias $field" + #matching variable in order to detect attempted use as property and throw error + + #2018 + #Note that we are adding a trace on a variable (the refname) which does not exist. + #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) + #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added + ##array set $refname {} ;#empty array + # - the empty array would mean a slightly better error message when misusing a command ref as an array + #but this seems like a code complication for little benefit + #review + + trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] + } +} + + + +#trailing. after command/property +proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { + if {[lindex $fullstack 0] eq "_exec_"} { + #strip it. This instruction isn't relevant for a reference. + set commandstack [lrange $fullstack 1 end] + } else { + set commandstack $fullstack + } + set argstack [lassign $commandstack command] + set field [string map {> __OBJECT_} [namespace tail $command]] + + + #!todo? + # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. + # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. + + + #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. + # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. + + + set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] + + if {[llength [info commands $refname]]} { + #todo - review - what if the field changed to/from a property/method? + #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs + return $refname + } + ::p::internals::create_or_update_reference $OID $_ID_ $refname $command + return $refname +} + + +namespace eval pp { + variable operators [list .. . -- - & @ # , !] + variable operators_notin_args "" + foreach op $operators { + append operators_notin_args "({$op} ni \$args) && " + } + set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands + #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} +} +interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! + + + + + +# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. +#each map is a 2 element list of lists. +# form: {$commandinfo $interfaceinfo} +# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} + +#2018 +#each map is a dict. +#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} + + +#OID = Object ID (integer for now - could in future be a uuid) +proc ::p::predator2 {_ID_ args} { + #puts stderr "predator2: _ID_:'$_ID_' args:'$args'" + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + + #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. + #set this_role_members [dict get $invocants this] + #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. + #lassign $this_invocant this_OID this_info_dict + + set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + + set cheat 1 ;# + #------- + #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) + #(it should be functionally equivalent to remove this shortcut block) + if {$cheat} { + if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { + + set remaining_args [lassign $args dot method_or_prop] + + #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? + set command ::p::${this_OID}::$method_or_prop + #REVIEW! + #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') + #if {[llength $command] > 1} { + # error "methods with spaces not included in test suites - todo fix!" + #} + #Dont use {*}$command - (so we can support methods with spaces) + #if {![llength [info commands $command]]} {} + if {[namespace which $command] eq ""} { + if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { + #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces + set command ::p::${this_OID}::(UNKNOWN) + #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" + } + } else { + #tailcall {*}$command $_ID_ {*}$remaining_args + tailcall $command $_ID_ {*}$remaining_args + } + } + } + #------------ + + + if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { + return $_ID_ + } + + + #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" + + + + #puts stderr "this_info_dict: $this_info_dict" + + + + + if {![llength $args]} { + #should return some sort of public info.. i.e probably not the ID which is an implementation detail + #return cmd + return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID + + #return a dict keyed on object command name - (suitable as use for a .. Create 'target') + #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped + #return [list $object_command [list -id $this_OID ]] + } elseif {[llength $args] == 1} { + #short-circuit the single index case for speed. + if {[lindex $args 0] ni {.. . -- - & @ # , !}} { + #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method + lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method + + tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] + } elseif {[lindex $args 0] eq {--}} { + + #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. + # - combined with using UUIDs for $OID, and a secured/removed metaface on the object + # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) + # - this could effectively hide the object's namespaces,vars etc from the caller (?) + return [set ::p::${this_OID}::_meta::map] + } + } + + + + #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) + #incr c + #set reduce ::p::reducer${this_OID}_$c + set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] + #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" + coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args + + + set current_ID_ $_ID_ + + set final 0 + set result "" + while {$final == 0} { + #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) + set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] + #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" + #if {[string match *Destroy $command]} { + # puts stdout " calling Destroy reduction_args:'$reduction_args'" + #} + if {$final == 1} { + + if {[llength $command] == 1} { + if {$command eq "_exec_"} { + tailcall {*}$reduction_args + } + if {[llength [info commands $command]]} { + tailcall {*}$command $current_ID_ {*}$reduction_args + } + set cmdname [namespace tail $command] + set this_OID [lindex [dict get $current_ID_ i this] 0 0] + if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { + lset command 0 ::p::${this_OID}::(UNKNOWN) + tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" + } + + } else { + #e.g lindex {a b c} + tailcall {*}$command {*}$reduction_args + } + + + } else { + if {[lindex $command 0] eq "_exec_"} { + set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] + + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] + } else { + if {[llength $command] == 1} { + if {![llength [info commands $command]]} { + set cmdname [namespace tail $command] + set this_OID [lindex [dict get $current_ID_ i this] 0 0] + if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { + + lset command 0 ::p::${this_OID}::(UNKNOWN) + set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" + } + } else { + #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] + set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] + + } + } else { + set result [uplevel 1 [list {*}$command {*}$reduction_args]] + } + + if {[llength [info commands $result]]} { + if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { + #looks like a pattern command + set current_ID_ [$result .. INVOCANTDATA] + + + #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA + #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { + # set current_ID_ $result_invocantdata + #} else { + # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" + #} + } else { + #non-pattern command + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + } + } else { + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) + + } + } + + } + } + error "Assert: Shouldn't get here (end of ::p::predator2)" + #return $result +} diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 50ea5082..61a454fa 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -2469,7 +2469,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 { @@ -5116,6 +5116,7 @@ tcl::namespace::eval punk::ansi::ta { # arrow keys -> ESC O A, ESC O B, ESC O C, ESC O D # plus more for auxiliary keypad codes in keypad application mode (and some in numeric mode) + #regexp expanded syntax = ?x variable re_ansi_detect {(?x) (?:\x1b(?:\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|c|7|8|M|D|E|H|=|>|<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.))|\((?:0|B)|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|(?:\#(?:3|4|5|6|8)))) |(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c) diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm index 60764f07..aaa595ae 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -108,8 +108,10 @@ namespace eval punk::cap::handlers::templates { #todo - handle wrapped or unwrapped tarjar files - in which case we have to adjust tmfolder appropriately #set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder - set projectinfo [punk::repo::find_repos $tmfolder] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $tmfolder] ;#slow - REVIEW + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $tmfolder] + #store the projectbase even if it's empty string set extended_capdict $capdict set resolved_path [file join $tmfolder $path] @@ -148,8 +150,9 @@ namespace eval punk::cap::handlers::templates { return 0 } set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review - set projectinfo [punk::repo::find_repos $shellbase] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $shellbase] + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $shellbase] set extended_capdict $capdict dict set extended_capdict vendor $vendor @@ -166,8 +169,9 @@ namespace eval punk::cap::handlers::templates { return 0 } set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review - set projectinfo [punk::repo::find_repos $shellbase] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $shellbase] + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $shellbase] set extended_capdict $capdict dict set extended_capdict vendor $vendor @@ -183,8 +187,9 @@ namespace eval punk::cap::handlers::templates { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' which doesn't seem to exist" return 0 } - set projectinfo [punk::repo::find_repos $normpath] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $normpath] + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $normpath] #todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder set extended_capdict $capdict @@ -244,6 +249,18 @@ namespace eval punk::cap::handlers::templates { # -- --- --- --- --- --- --- namespace export * namespace eval class { + variable PUNKARGS + #set argd [punk::args::get_dict { + # @id -id "::punk::cap::handlers::templates::class::api folders" + # -startdir -default "" + # @values -max 0 + #} $args] + lappend PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api folders" + -startdir -default "" + @values -max 0 + }] + oo::class create api { #return a dict keyed on folder with source pkg as value constructor {capname} { @@ -253,11 +270,8 @@ namespace eval punk::cap::handlers::templates { set capabilityname $capname } method folders {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api folders" - -startdir -default "" - @values -max 0 - } $args] + #puts "--folders $args" + set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] set opts [dict get $argd opts] set opt_startdir [dict get $opts -startdir] @@ -270,6 +284,10 @@ namespace eval punk::cap::handlers::templates { set startdir $opt_startdir } } + set searchbase $startdir + #set pathinfo [punk::repo::find_repos $searchbase] ;#relatively slow! REVIEW - pass as arg? cache? + #set pwd_projectroot [dict get $pathinfo closest] + set pwd_projectroot [punk::repo::find_project $searchbase] variable capabilityname @@ -314,9 +332,9 @@ namespace eval punk::cap::handlers::templates { set module_projectroot [dict get $capdecl_extended projectbase] dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot] } elseif {$pathtype eq "currentproject_multivendor"} { - set searchbase $startdir - set pathinfo [punk::repo::find_repos $searchbase] - set pwd_projectroot [dict get $pathinfo closest] + #set searchbase $startdir + #set pathinfo [punk::repo::find_repos $searchbase] + #set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { set deckbase [file join $pwd_projectroot $path] if {![file exists $deckbase]} { @@ -349,9 +367,9 @@ namespace eval punk::cap::handlers::templates { } } } elseif {$pathtype eq "currentproject"} { - set searchbase $startdir - set pathinfo [punk::repo::find_repos $searchbase] - set pwd_projectroot [dict get $pathinfo closest] + #set searchbase $startdir + #set pathinfo [punk::repo::find_repos $searchbase] + #set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { #path relative to projectroot already validated by handler as being within a currentproject_multivendor tree set targetfolder [file join $pwd_projectroot $path] @@ -489,8 +507,9 @@ namespace eval punk::cap::handlers::templates { set refdict [my get_itemdict_projectlayoutrefs {*}$args] set layoutdict [dict create] - set projectinfo [punk::repo::find_repos $searchbase] - set projectroot [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $searchbase] + #set projectroot [dict get $projectinfo closest] + set projectroot [punk::repo::find_project $searchbase] dict for {layoutname refinfo} $refdict { set templatepathtype [dict get $refinfo sourceinfo pathtype] @@ -760,6 +779,10 @@ namespace eval punk::cap::handlers::templates { } +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::cap::handlers::templates ::punk::cap::handlers::templates::class +} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm index ac70e97b..5532cb80 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -1,487 +1,487 @@ - -tcl::namespace::eval punk::config { - variable loaded - variable startup ;#include env overrides - variable running - variable punk_env_vars - variable other_env_vars - - variable vars - - namespace export {[a-z]*} - - #todo - XDG_DATA_HOME etc - #https://specifications.freedesktop.org/basedir-spec/latest/ - # see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ - - proc init {} { - variable defaults - variable startup - variable running - variable punk_env_vars - variable punk_env_vars_config - variable other_env_vars - variable other_env_vars_config - - set exename "" - catch { - #catch for safe interps - #safe base will return empty string, ordinary safe interp will raise error - set exename [tcl::info::nameofexecutable] - } - if {$exename ne ""} { - set exefolder [file dirname $exename] - #default file logs to logs folder at same level as exe if writable, or empty string - set log_folder [file normalize $exefolder/../logs] ;#~2ms - #tcl::dict::set startup scriptlib $exefolder/scriptlib - #tcl::dict::set startup apps $exefolder/../../punkapps - - #todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc - set default_scriptlib $exefolder/scriptlib - set default_apps $exefolder/../../punkapps - if {[file isdirectory $log_folder] && [file writable $log_folder]} { - #tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt - #tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt - set default_logfile_stdout $log_folder/repl-exec-stdout.txt - set default_logfile_stderr $log_folder/repl-exec-stderr.txt - } else { - set default_logfile_stdout "" - set default_logfile_stderr "" - } - } else { - #probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island - #review - todo? - #tcl::dict::set startup scriptlib "" - #tcl::dict::set startup apps "" - set default_scriptlib "" - set default_apps "" - set default_logfile_stdout "" - set default_logfile_stderr "" - } - - # auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run - - #optional channel transforms on stdout/stderr. - #can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands - #If no distinction necessary - should use default_color_ - #The counterpart: default_color__repl is a transform that is added and removed with each repl evaluation. - #startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default - set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) - set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only - #This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. - #set default_color_stderr "red bold" - #set default_color_stderr "web-lightsalmon" - set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive - set default_color_stderr_repl "" ;#during repl call only - - set homedir "" - if {[catch { - #depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp - #other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp - set homedir [file home] - } errM]} { - #tcl 8.6 doesn't have file home.. try again - if {[info exists ::env(HOME)]} { - set homedir $::env(HOME) - } - } - - - # per user xdg vars - # --- - set default_xdg_config_home "" ;#config data - portable - set default_xdg_data_home "" ;#data the user likely to want to be portable - set default_xdg_cache_home "" ;#local cache - set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home - # --- - set default_xdg_data_dirs "" ;#non-user specific - #xdg_config_dirs ? - #xdg_runtime_dir ? - - - #review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) - #(safe interp generally won't have access to ::env either) - #This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. - if {$homedir ne ""} { - if {"windows" eq $::tcl_platform(platform)} { - #as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. - #we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) - #using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. - if {[info exists ::env(APPDATA)]} { - set default_xdg_config_home $::env(APPDATA) - set default_xdg_data_home $::env(APPDATA) - } - - #The xdg_cache_home should be kept local - if {[info exists ::env(LOCALAPPDATA)]} { - set default_xdg_cache_home $::env(LOCALAPPDATA) - set default_xdg_state_home $::env(LOCALAPPDATA) - } - - if {[info exists ::env(PROGRAMDATA)]} { - #- equiv env(ALLUSERSPROFILE) ? - set default_xdg_data_dirs $::env(PROGRAMDATA) - } - - } else { - #follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html - set default_xdg_config_home [file join $homedir .config] - set default_xdg_data_home [file join $homedir .local share] - set default_xdg_cache_home [file join $homedir .cache] - set default_xdg_state_home [file join $homedir .local state] - set default_xdg_data_dirs /usr/local/share - } - } - - set defaults [dict create\ - apps $default_apps\ - config ""\ - configset ".punkshell"\ - scriptlib $default_scriptlib\ - color_stdout $default_color_stdout\ - color_stdout_repl $default_color_stdout_repl\ - color_stderr $default_color_stderr\ - color_stderr_repl $default_color_stderr_repl\ - logfile_stdout $default_logfile_stdout\ - logfile_stderr $default_logfile_stderr\ - logfile_active 0\ - syslog_stdout "127.0.0.1:514"\ - syslog_stderr "127.0.0.1:514"\ - syslog_active 0\ - auto_exec_mechanism exec\ - auto_noexec 0\ - xdg_config_home $default_xdg_config_home\ - xdg_data_home $default_xdg_data_home\ - xdg_cache_home $default_xdg_cache_home\ - xdg_state_home $default_xdg_state_home\ - xdg_data_dirs $default_xdg_data_dirs\ - theme_posh_override ""\ - posh_theme ""\ - posh_themes_path ""\ - ] - - set startup $defaults - #load values from saved config file - $xdg_config_home/punk/punk.config ? - #typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. - #that's possibly ok for the PUNK_ vars - #however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? - #making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? - #simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden - #- requiring user to manually unset any unwanted env vars when launching? - - #we are likely to want the saved configs for subshells/decks to override them however. - - #todo - load/save config file - - #todo - define which configvars are settable in env - #list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) - set punk_env_vars_config [dict create \ - PUNK_APPS {type pathlist}\ - PUNK_CONFIG {type string}\ - PUNK_CONFIGSET {type string}\ - PUNK_SCRIPTLIB {type string}\ - PUNK_AUTO_EXEC_MECHANISM {type string}\ - PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ - PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ - PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ - PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ - PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ - PUNK_LOGFILE_STDOUT {type string}\ - PUNK_LOGFILE_STDERR {type string}\ - PUNK_LOGFILE_ACTIVE {type string}\ - PUNK_SYSLOG_STDOUT {type string}\ - PUNK_SYSLOG_STDERR {type string}\ - PUNK_SYSLOG_ACTIVE {type string}\ - PUNK_THEME_POSH_OVERRIDE {type string}\ - ] - set punk_env_vars [dict keys $punk_env_vars_config] - - #override with env vars if set - foreach {evar varinfo} $punk_env_vars_config { - if {[info exists ::env($evar)]} { - set vartype [dict get $varinfo type] - set f [set ::env($evar)] - if {$f ne "default"} { - #e.g PUNK_SCRIPTLIB -> scriptlib - set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] - if {$vartype eq "pathlist"} { - #colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system - #Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. - #For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. - #some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. - #An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting - # - but some programs have been known to split this value on colon anyway, which breaks things on windows. - set paths [split $f $::tcl_platform(pathSeparator)] - set final [list] - #eliminate empty values (leading or trailing or extraneous separators) - foreach p $paths { - if {[tcl::string::trim $p] ne ""} { - lappend final $p - } - } - tcl::dict::set startup $varname $final - } else { - tcl::dict::set startup $varname $f - } - } - } - } - - # https://no-color.org - #if {[info exists ::env(NO_COLOR)]} { - # if {$::env(NO_COLOR) ne ""} { - # set colour_disabled 1 - # } - #} - set other_env_vars_config [dict create\ - NO_COLOR {type string}\ - XDG_CONFIG_HOME {type string}\ - XDG_DATA_HOME {type string}\ - XDG_CACHE_HOME {type string}\ - XDG_STATE_HOME {type string}\ - XDG_DATA_DIRS {type pathlist}\ - POSH_THEME {type string}\ - POSH_THEMES_PATH {type string}\ - TCLLIBPATH {type string}\ - ] - lassign [split [info tclversion] .] tclmajorv tclminorv - #don't rely on lseq or punk::lib for now.. - set relevant_minors [list] - for {set i 0} {$i <= $tclminorv} {incr i} { - lappend relevant_minors $i - } - foreach minor $relevant_minors { - set vname TCL${tclmajorv}_${minor}_TM_PATH - if {$minor eq $tclminorv || [info exists ::env($vname)]} { - dict set other_env_vars_config $vname {type string} - } - } - set other_env_vars [dict keys $other_env_vars_config] - - foreach {evar varinfo} $other_env_vars_config { - if {[info exists ::env($evar)]} { - set vartype [dict get $varinfo type] - set f [set ::env($evar)] - if {$f ne "default"} { - set varname [tcl::string::tolower $evar] - if {$vartype eq "pathlist"} { - set paths [split $f $::tcl_platform(pathSeparator)] - set final [list] - #eliminate empty values (leading or trailing or extraneous separators) - foreach p $paths { - if {[tcl::string::trim $p] ne ""} { - lappend final $p - } - } - tcl::dict::set startup $varname $final - } else { - tcl::dict::set startup $varname $f - } - } - } - } - - - #unset -nocomplain vars - - #todo - set running [tcl::dict::create] - set running [tcl::dict::merge $running $startup] - } - init - - #todo - proc Apply {config} { - puts stderr "punk::config::Apply partially implemented" - set configname [string map {-config ""} $config] - if {$configname in {startup running}} { - upvar ::punk::config::$configname applyconfig - - if {[dict exists $applyconfig auto_noexec]} { - set auto [dict get $applyconfig auto_noexec] - if {![string is boolean -strict $auto]} { - error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" - } - if {$auto} { - set ::auto_noexec 1 - } else { - #puts "auto_noexec false" - unset -nocomplain ::auto_noexec - } - } - - } else { - error "no config named '$config' found" - } - return "apply done" - } - Apply startup - - #todo - consider how to divide up settings, categories, 'devices', decks etc - proc get_running_global {varname} { - variable running - if {[dict exists $running $varname]} { - return [dict get $running $varname] - } - error "No such global configuration item '$varname' found in running config" - } - proc get_startup_global {varname} { - variable startup - if {[dict exists $startup $varname]} { - return [dict get $startup $varname] - } - error "No such global configuration item '$varname' found in startup config" - } - - proc get {whichconfig {globfor *}} { - variable startup - variable running - switch -- $whichconfig { - config - startup - startup-config - startup-configuration { - #show *startup* config - different behaviour may be confusing to those used to router startup and running configs - set configdata $startup - } - running - running-config - running-configuration { - set configdata $running - } - default { - error "Unknown config name '$whichconfig' - try startup or running" - } - } - if {$globfor eq "*"} { - return $configdata - } else { - set keys [dict keys $configdata [string tolower $globfor]] - set filtered [dict create] - foreach k $keys { - dict set filtered $k [dict get $configdata $k] - } - return $filtered - } - } - - proc configure {args} { - set argdef { - @id -id ::punk::config::configure - @cmd -name punk::config::configure -help\ - "UNIMPLEMENTED" - @values -min 1 -max 1 - whichconfig -type string -choices {startup running stop} - } - set argd [punk::args::get_dict $argdef $args] - return "unimplemented - $argd" - } - - proc show {whichconfig {globfor *}} { - #todo - tables for console - set configdata [punk::config::get $whichconfig $globfor] - return [punk::lib::showdict $configdata] - } - - - - #e.g - # copy running-config startup-config - # copy startup-config test-config.cfg - # copy backup-config.cfg running-config - #review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite - #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration - proc copy {args} { - set argdef { - @id -id ::punk::config::copy - @cmd -name punk::config::copy -help\ - "Copy a partial or full configuration from one config to another - If a target config has additional settings, then the source config can be considered to be partial with regards to the target. - " - -type -default "" -choices {replace merge} -help\ - "Defaults to merge when target is running-config - Defaults to replace when source is running-config" - @values -min 2 -max 2 - fromconfig -help\ - "running or startup or file name (not fully implemented)" - toconfig -help\ - "running or startup or file name (not fully implemented)" - } - set argd [punk::args::get_dict $argdef $args] - set fromconfig [dict get $argd values fromconfig] - set toconfig [dict get $argd values toconfig] - set fromconfig [string map {-config ""} $fromconfig] - set toconfig [string map {-config ""} $toconfig] - - set copytype [dict get $argd opts -type] - - - #todo - warn & prompt if doing merge copy to startup - switch -exact -- $fromconfig-$toconfig { - running-startup { - if {$copytype eq ""} { - set copytype replace ;#full configuration - } - if {$copytype eq "replace"} { - error "punk::config::copy error. full configuration copy from running to startup config not yet supported" - } else { - error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" - } - } - startup-running { - #default type merge - even though it's not always what is desired - if {$copytype eq ""} { - set copytype merge ;#load in a partial configuration - } - - #warn/prompt either way - if {$copytype eq "replace"} { - #some routers require use of a separate command for this branch. - #presumably to ensure the user doesn't accidentally load partials onto a running system - # - error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" - } else { - error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" - } - } - default { - error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" - } - } - } - - - - - -} - - - - - -#todo - move to cli? -::tcl::namespace::eval punk::config { - #todo - something better - 'previous' rather than reverting to startup - proc channelcolors {{onoff {}}} { - variable running - variable startup - - if {![string length $onoff]} { - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] - } else { - if {![string is boolean $onoff]} { - error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" - } - if {$onoff} { - dict set running color_stdout [dict get $startup color_stdout] - dict set running color_stderr [dict get $startup color_stderr] - } else { - dict set running color_stdout "" - dict set running color_stderr "" - } - } - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] - } -} - -package provide punk::config [tcl::namespace::eval punk::config { - variable version - set version 0.1 - + +tcl::namespace::eval punk::config { + variable loaded + variable startup ;#include env overrides + variable running + variable punk_env_vars + variable other_env_vars + + variable vars + + namespace export {[a-z]*} + + #todo - XDG_DATA_HOME etc + #https://specifications.freedesktop.org/basedir-spec/latest/ + # see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ + + proc init {} { + variable defaults + variable startup + variable running + variable punk_env_vars + variable punk_env_vars_config + variable other_env_vars + variable other_env_vars_config + + set exename "" + catch { + #catch for safe interps + #safe base will return empty string, ordinary safe interp will raise error + set exename [tcl::info::nameofexecutable] + } + if {$exename ne ""} { + set exefolder [file dirname $exename] + #default file logs to logs folder at same level as exe if writable, or empty string + set log_folder [file normalize $exefolder/../logs] ;#~2ms + #tcl::dict::set startup scriptlib $exefolder/scriptlib + #tcl::dict::set startup apps $exefolder/../../punkapps + + #todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc + set default_scriptlib $exefolder/scriptlib + set default_apps $exefolder/../../punkapps + if {[file isdirectory $log_folder] && [file writable $log_folder]} { + #tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt + #tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt + set default_logfile_stdout $log_folder/repl-exec-stdout.txt + set default_logfile_stderr $log_folder/repl-exec-stderr.txt + } else { + set default_logfile_stdout "" + set default_logfile_stderr "" + } + } else { + #probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island + #review - todo? + #tcl::dict::set startup scriptlib "" + #tcl::dict::set startup apps "" + set default_scriptlib "" + set default_apps "" + set default_logfile_stdout "" + set default_logfile_stderr "" + } + + # auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run + + #optional channel transforms on stdout/stderr. + #can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands + #If no distinction necessary - should use default_color_ + #The counterpart: default_color__repl is a transform that is added and removed with each repl evaluation. + #startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default + set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) + set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only + #This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. + #set default_color_stderr "red bold" + #set default_color_stderr "web-lightsalmon" + set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive + set default_color_stderr_repl "" ;#during repl call only + + set homedir "" + if {[catch { + #depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp + #other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp + set homedir [file home] + } errM]} { + #tcl 8.6 doesn't have file home.. try again + if {[info exists ::env(HOME)]} { + set homedir $::env(HOME) + } + } + + + # per user xdg vars + # --- + set default_xdg_config_home "" ;#config data - portable + set default_xdg_data_home "" ;#data the user likely to want to be portable + set default_xdg_cache_home "" ;#local cache + set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home + # --- + set default_xdg_data_dirs "" ;#non-user specific + #xdg_config_dirs ? + #xdg_runtime_dir ? + + + #review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) + #(safe interp generally won't have access to ::env either) + #This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. + if {$homedir ne ""} { + if {"windows" eq $::tcl_platform(platform)} { + #as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. + #we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) + #using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. + if {[info exists ::env(APPDATA)]} { + set default_xdg_config_home $::env(APPDATA) + set default_xdg_data_home $::env(APPDATA) + } + + #The xdg_cache_home should be kept local + if {[info exists ::env(LOCALAPPDATA)]} { + set default_xdg_cache_home $::env(LOCALAPPDATA) + set default_xdg_state_home $::env(LOCALAPPDATA) + } + + if {[info exists ::env(PROGRAMDATA)]} { + #- equiv env(ALLUSERSPROFILE) ? + set default_xdg_data_dirs $::env(PROGRAMDATA) + } + + } else { + #follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html + set default_xdg_config_home [file join $homedir .config] + set default_xdg_data_home [file join $homedir .local share] + set default_xdg_cache_home [file join $homedir .cache] + set default_xdg_state_home [file join $homedir .local state] + set default_xdg_data_dirs /usr/local/share + } + } + + set defaults [dict create\ + apps $default_apps\ + config ""\ + configset ".punkshell"\ + scriptlib $default_scriptlib\ + color_stdout $default_color_stdout\ + color_stdout_repl $default_color_stdout_repl\ + color_stderr $default_color_stderr\ + color_stderr_repl $default_color_stderr_repl\ + logfile_stdout $default_logfile_stdout\ + logfile_stderr $default_logfile_stderr\ + logfile_active 0\ + syslog_stdout "127.0.0.1:514"\ + syslog_stderr "127.0.0.1:514"\ + syslog_active 0\ + auto_exec_mechanism exec\ + auto_noexec 0\ + xdg_config_home $default_xdg_config_home\ + xdg_data_home $default_xdg_data_home\ + xdg_cache_home $default_xdg_cache_home\ + xdg_state_home $default_xdg_state_home\ + xdg_data_dirs $default_xdg_data_dirs\ + theme_posh_override ""\ + posh_theme ""\ + posh_themes_path ""\ + ] + + set startup $defaults + #load values from saved config file - $xdg_config_home/punk/punk.config ? + #typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. + #that's possibly ok for the PUNK_ vars + #however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? + #making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? + #simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden + #- requiring user to manually unset any unwanted env vars when launching? + + #we are likely to want the saved configs for subshells/decks to override them however. + + #todo - load/save config file + + #todo - define which configvars are settable in env + #list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) + set punk_env_vars_config [dict create \ + PUNK_APPS {type pathlist}\ + PUNK_CONFIG {type string}\ + PUNK_CONFIGSET {type string}\ + PUNK_SCRIPTLIB {type string}\ + PUNK_AUTO_EXEC_MECHANISM {type string}\ + PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ + PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ + PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ + PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ + PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ + PUNK_LOGFILE_STDOUT {type string}\ + PUNK_LOGFILE_STDERR {type string}\ + PUNK_LOGFILE_ACTIVE {type string}\ + PUNK_SYSLOG_STDOUT {type string}\ + PUNK_SYSLOG_STDERR {type string}\ + PUNK_SYSLOG_ACTIVE {type string}\ + PUNK_THEME_POSH_OVERRIDE {type string}\ + ] + set punk_env_vars [dict keys $punk_env_vars_config] + + #override with env vars if set + foreach {evar varinfo} $punk_env_vars_config { + if {[info exists ::env($evar)]} { + set vartype [dict get $varinfo type] + set f [set ::env($evar)] + if {$f ne "default"} { + #e.g PUNK_SCRIPTLIB -> scriptlib + set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] + if {$vartype eq "pathlist"} { + #colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system + #Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. + #For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. + #some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. + #An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting + # - but some programs have been known to split this value on colon anyway, which breaks things on windows. + set paths [split $f $::tcl_platform(pathSeparator)] + set final [list] + #eliminate empty values (leading or trailing or extraneous separators) + foreach p $paths { + if {[tcl::string::trim $p] ne ""} { + lappend final $p + } + } + tcl::dict::set startup $varname $final + } else { + tcl::dict::set startup $varname $f + } + } + } + } + + # https://no-color.org + #if {[info exists ::env(NO_COLOR)]} { + # if {$::env(NO_COLOR) ne ""} { + # set colour_disabled 1 + # } + #} + set other_env_vars_config [dict create\ + NO_COLOR {type string}\ + XDG_CONFIG_HOME {type string}\ + XDG_DATA_HOME {type string}\ + XDG_CACHE_HOME {type string}\ + XDG_STATE_HOME {type string}\ + XDG_DATA_DIRS {type pathlist}\ + POSH_THEME {type string}\ + POSH_THEMES_PATH {type string}\ + TCLLIBPATH {type string}\ + ] + lassign [split [info tclversion] .] tclmajorv tclminorv + #don't rely on lseq or punk::lib for now.. + set relevant_minors [list] + for {set i 0} {$i <= $tclminorv} {incr i} { + lappend relevant_minors $i + } + foreach minor $relevant_minors { + set vname TCL${tclmajorv}_${minor}_TM_PATH + if {$minor eq $tclminorv || [info exists ::env($vname)]} { + dict set other_env_vars_config $vname {type string} + } + } + set other_env_vars [dict keys $other_env_vars_config] + + foreach {evar varinfo} $other_env_vars_config { + if {[info exists ::env($evar)]} { + set vartype [dict get $varinfo type] + set f [set ::env($evar)] + if {$f ne "default"} { + set varname [tcl::string::tolower $evar] + if {$vartype eq "pathlist"} { + set paths [split $f $::tcl_platform(pathSeparator)] + set final [list] + #eliminate empty values (leading or trailing or extraneous separators) + foreach p $paths { + if {[tcl::string::trim $p] ne ""} { + lappend final $p + } + } + tcl::dict::set startup $varname $final + } else { + tcl::dict::set startup $varname $f + } + } + } + } + + + #unset -nocomplain vars + + #todo + set running [tcl::dict::create] + set running [tcl::dict::merge $running $startup] + } + init + + #todo + proc Apply {config} { + puts stderr "punk::config::Apply partially implemented" + set configname [string map {-config ""} $config] + if {$configname in {startup running}} { + upvar ::punk::config::$configname applyconfig + + if {[dict exists $applyconfig auto_noexec]} { + set auto [dict get $applyconfig auto_noexec] + if {![string is boolean -strict $auto]} { + error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" + } + if {$auto} { + set ::auto_noexec 1 + } else { + #puts "auto_noexec false" + unset -nocomplain ::auto_noexec + } + } + + } else { + error "no config named '$config' found" + } + return "apply done" + } + Apply startup + + #todo - consider how to divide up settings, categories, 'devices', decks etc + proc get_running_global {varname} { + variable running + if {[dict exists $running $varname]} { + return [dict get $running $varname] + } + error "No such global configuration item '$varname' found in running config" + } + proc get_startup_global {varname} { + variable startup + if {[dict exists $startup $varname]} { + return [dict get $startup $varname] + } + error "No such global configuration item '$varname' found in startup config" + } + + proc get {whichconfig {globfor *}} { + variable startup + variable running + switch -- $whichconfig { + config - startup - startup-config - startup-configuration { + #show *startup* config - different behaviour may be confusing to those used to router startup and running configs + set configdata $startup + } + running - running-config - running-configuration { + set configdata $running + } + default { + error "Unknown config name '$whichconfig' - try startup or running" + } + } + if {$globfor eq "*"} { + return $configdata + } else { + set keys [dict keys $configdata [string tolower $globfor]] + set filtered [dict create] + foreach k $keys { + dict set filtered $k [dict get $configdata $k] + } + return $filtered + } + } + + proc configure {args} { + set argdef { + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ + "UNIMPLEMENTED" + @values -min 1 -max 1 + whichconfig -type string -choices {startup running stop} + } + set argd [punk::args::get_dict $argdef $args] + return "unimplemented - $argd" + } + + proc show {whichconfig {globfor *}} { + #todo - tables for console + set configdata [punk::config::get $whichconfig $globfor] + return [punk::lib::showdict $configdata] + } + + + + #e.g + # copy running-config startup-config + # copy startup-config test-config.cfg + # copy backup-config.cfg running-config + #review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite + #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration + proc copy {args} { + set argdef { + @id -id ::punk::config::copy + @cmd -name punk::config::copy -help\ + "Copy a partial or full configuration from one config to another + If a target config has additional settings, then the source config can be considered to be partial with regards to the target. + " + -type -default "" -choices {replace merge} -help\ + "Defaults to merge when target is running-config + Defaults to replace when source is running-config" + @values -min 2 -max 2 + fromconfig -help\ + "running or startup or file name (not fully implemented)" + toconfig -help\ + "running or startup or file name (not fully implemented)" + } + set argd [punk::args::get_dict $argdef $args] + set fromconfig [dict get $argd values fromconfig] + set toconfig [dict get $argd values toconfig] + set fromconfig [string map {-config ""} $fromconfig] + set toconfig [string map {-config ""} $toconfig] + + set copytype [dict get $argd opts -type] + + + #todo - warn & prompt if doing merge copy to startup + switch -exact -- $fromconfig-$toconfig { + running-startup { + if {$copytype eq ""} { + set copytype replace ;#full configuration + } + if {$copytype eq "replace"} { + error "punk::config::copy error. full configuration copy from running to startup config not yet supported" + } else { + error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" + } + } + startup-running { + #default type merge - even though it's not always what is desired + if {$copytype eq ""} { + set copytype merge ;#load in a partial configuration + } + + #warn/prompt either way + if {$copytype eq "replace"} { + #some routers require use of a separate command for this branch. + #presumably to ensure the user doesn't accidentally load partials onto a running system + # + error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" + } else { + error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" + } + } + default { + error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" + } + } + } + + + + + +} + + + + + +#todo - move to cli? +::tcl::namespace::eval punk::config { + #todo - something better - 'previous' rather than reverting to startup + proc channelcolors {{onoff {}}} { + variable running + variable startup + + if {![string length $onoff]} { + return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + } else { + if {![string is boolean $onoff]} { + error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" + } + if {$onoff} { + dict set running color_stdout [dict get $startup color_stdout] + dict set running color_stderr [dict get $startup color_stderr] + } else { + dict set running color_stdout "" + dict set running color_stderr "" + } + } + return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + } +} + +package provide punk::config [tcl::namespace::eval punk::config { + variable version + set version 0.1 + }] \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm index 69f2f5cb..a4bc3c70 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -767,6 +767,8 @@ namespace eval punk::mix::base { dict for {path pathinfo} $dict_path_cksum { + puts "fill_relativecksums_from_base_and_relativepathdict-->$path REVIEW" + #review to see if we process same path repeatedly, so could avoid repeated 'file exists $fullpath' below by caching a glob if {![dict exists $pathinfo cksum]} { dict set pathinfo cksum "" } else { @@ -851,7 +853,7 @@ namespace eval punk::mix::base { } } else { - if {[file type $specifiedpath] eq "relative"} { + if {[file pathtype $specifiedpath] eq "relative"} { #if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage set targetpath [file normalize $specifiedpath] set storedpath $targetpath @@ -911,6 +913,7 @@ namespace eval punk::mix::base { } #buildruntime.exe obsolete.. + puts stderr "warning obsolete? get_all_vfs_build_cksums 'buildruntime.exe'???" set fullpath_buildruntime $buildfolder/buildruntime.exe set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 3cf64b33..a099c9b0 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -412,9 +412,9 @@ namespace eval punk::mix::cli { set repopaths [punk::repo::find_repos [pwd]] set repos [dict get $repopaths repos] if {![llength $repos]} { - append result [dict get $repopaths warnings] + append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] } else { - append result [dict get $repopaths warnings] + append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] lassign [lindex $repos 0] repopath repotypes if {"fossil" in $repotypes} { #review - multiple process launches to fossil a bit slow on windows.. @@ -739,7 +739,7 @@ namespace eval punk::mix::cli { } } else { - puts -nonewline stderr "." + puts -nonewline stderr "P" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $build_event targetset_end SKIPPED @@ -771,7 +771,7 @@ namespace eval punk::mix::cli { $event targetset_end OK -note "zip modpod" } } else { - puts -nonewline stderr "." + puts -nonewline stderr "p" set did_skip 1 if {$is_interesting} { puts stderr "$modulefile [$event targetset_source_changes]" @@ -893,7 +893,7 @@ namespace eval punk::mix::cli { if {$is_interesting} { puts stdout "skipping module $current_source_dir/$m - no change in sources detected" } - puts -nonewline stderr "." + puts -nonewline stderr "m" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $event targetset_end SKIPPED @@ -935,7 +935,7 @@ namespace eval punk::mix::cli { #set file_record [punkcheck::installfile_finished_install $basedir $file_record] $event targetset_end OK -note "already versioned module" } else { - puts -nonewline stderr "." + puts -nonewline stderr "f" set did_skip 1 if {$is_interesting} { puts stderr "$current_source_dir/$m [$event targetset_source_changes]" @@ -951,7 +951,8 @@ namespace eval punk::mix::cli { if {$CALLDEPTH >= $max_depth} { set subdirs [list] } else { - set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set targets_existing [glob -nocomplain -dir $target_module_dir -type d -tail {*}$subdirs] } #puts stderr "subdirs: $subdirs" foreach d $subdirs { @@ -965,7 +966,10 @@ namespace eval punk::mix::cli { if {$skipdir} { continue } - if {![file exists $target_module_dir/$d]} { + #if {![file exists $target_module_dir/$d]} { + # file mkdir $target_module_dir/$d + #} + if {$d ni $targets_existing} { file mkdir $target_module_dir/$d } lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm index 883e02d2..409796fc 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm @@ -49,7 +49,7 @@ namespace eval punk::mix::commandset::buildsuite { set path_parts [file split [lindex $du_record 1]] ;#should handle spaced-paths ok. set s [lindex $path_parts end-1] set p [lindex $path_parts end] - + #This handles case where a project folder is same name as suite e.g src/buildsuites/tcl/tcl #so we can't just use tail as dict key. We could assume last record is always total - but if {![string match -nocase $s $suite]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm index c6c83b69..a3784c00 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm @@ -26,7 +26,7 @@ namespace eval punk::mix::commandset::debug { namespace export get paths namespace path ::punk::mix::cli - #Except for 'get' - all debug commands should emit to stdout + #Except for 'get' - all debug commands should emit to stdout proc paths {} { set out "" puts stdout "find_repos output:" @@ -40,7 +40,7 @@ namespace eval punk::mix::commandset::debug { set template_base_dict [punk::mix::base::lib::get_template_basefolders] puts stdout "get_template_basefolders output:" pdict template_base_dict */* - return + return } #call other debug command - but capture stdout as return value @@ -84,9 +84,9 @@ namespace eval punk::mix::commandset::debug { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index ae21d348..2bc0f01c 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -26,8 +26,10 @@ namespace eval punk::mix::commandset::module { namespace export * proc paths {} { - set roots [punk::repo::find_repos ""] - set project [lindex [dict get $roots project] 0] + #set roots [punk::repo::find_repos ""] + #set project [lindex [dict get $roots project] 0] + set project [punk::repo::find_project ""] + if {$project ne ""} { set is_project 1 set searchbase $project 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 2ff8ac06..f670c8c0 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 @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.0] #[copyright "2023"] #[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] -#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] +#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] #[require punk::mix::commandset::project] #[description] @@ -29,25 +29,25 @@ #*** !doctools #[section Overview] #[para] overview of punk::mix::commandset::project -#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g +#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g #[example { # namespace eval myproject::cli { # namespace export * # namespace ensemble create # package require punk::overlay -# +# # package require punk::mix::commandset::project # punk::overlay::import_commandset project . ::punk::mix::commandset::project -# punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection +# punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection # } #}] #[para] Where the . in the above example is the prefix/command separator #[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. -#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new +#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new #[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as projects. #[para] #[subsection Concepts] -#[para] see punk::overlay +#[para] see punk::overlay # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -56,7 +56,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::mix::commandset::project +#[para] packages used by punk::mix::commandset::project #[list_begin itemized] package require Tcl 8.6- @@ -88,7 +88,7 @@ namespace eval punk::mix::commandset::project { namespace export * #*** !doctools #[subsection {Namespace punk::mix::commandset::project}] - #[para] core commandset functions for punk::mix::commandset::project + #[para] core commandset functions for punk::mix::commandset::project #[list_begin definitions] proc _default {} { @@ -133,7 +133,7 @@ namespace eval punk::mix::commandset::project { proc new {newprojectpath_or_name args} { #*** !doctools # [call [fun new] [arg newprojectpath_or_name] [opt args]] - #new project structure - may be dedicated to one module, or contain many. + #new project structure - may be dedicated to one module, or contain many. #create minimal folder structure only by specifying in args: -modules {} if {[file pathtype $newprojectpath_or_name] eq "absolute"} { set projectfullpath [file normalize $newprojectpath_or_name] @@ -185,7 +185,7 @@ namespace eval punk::mix::commandset::project { if {$opt_force || $opt_update} { #generally undesirable to add default project module during an update. #user can use dev module.new manually or supply module name in -modules - set opt_modules [list] + set opt_modules [list] } else { set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl } @@ -207,12 +207,12 @@ namespace eval punk::mix::commandset::project { } #we don't assume 'unknown' is configured to run shell commands if {[string length [package provide shellrun]]} { - set exitinfo [run {*}$scoop_prog install fossil] + set exitinfo [run {*}$scoop_prog install fossil] #scoop tends to return successful exitcode (0) even when packages not found etc. - so exitinfo not much use. puts stdout "scoop install fossil ran with result: $exitinfo" } else { puts stdout "Please wait while scoop runs - there may be a slight delay and then scoop output will be shown. (use punk shellrun package for )" - set result [exec {*}$scoop_prog install fossil] + set result [exec {*}$scoop_prog install fossil] puts stdout $result } catch {::auto_reset} ;#can be missing (unsure under what circumstances - but I've seen it raise error 'invalid command name "auto_reset"') @@ -304,7 +304,7 @@ namespace eval punk::mix::commandset::project { } } - + set project_dir_exists [file exists $projectdir] if {$project_dir_exists && !($opt_force || $opt_update)} { puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" @@ -332,7 +332,7 @@ namespace eval punk::mix::commandset::project { puts stderr $warnmsg } - set fossil_repo_file "" + set fossil_repo_file "" set is_fossil_root 0 if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} { set is_fossil_root 1 @@ -356,7 +356,7 @@ namespace eval punk::mix::commandset::project { return } #review - set fossil_repo_file $repodb_folder/$projectname.fossil + set fossil_repo_file $repodb_folder/$projectname.fossil } if {$fossil_repo_file eq ""} { @@ -378,7 +378,7 @@ namespace eval punk::mix::commandset::project { file mkdir $projectdir - puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" + puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" set resultdict [dict create] set antipaths [list\ src/doc/*\ @@ -394,10 +394,10 @@ namespace eval punk::mix::commandset::project { #default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized if {$opt_force} { - puts stdout "copying layout files - with force applied - overwrite all-targets" + puts stdout "copying layout files - with force applied - overwrite all-targets" set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] } else { - puts stdout "copying layout files - (if source file changed)" + puts stdout "copying layout files - (if source file changed)" set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] } puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -410,10 +410,10 @@ namespace eval punk::mix::commandset::project { puts stdout "no src/doc in source template - update not required" } - #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. + #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. #In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. ## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] - set override_antiglob_dir_core [list #* _aside .git] + set override_antiglob_dir_core [list #* _aside .git] if {[file exists $layout_path/.fossil-custom]} { puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] @@ -430,9 +430,9 @@ namespace eval punk::mix::commandset::project { puts stdout "no .fossil-settings in source template - update not required" } - #scan all files in template + #scan all files in template # - #TODO - deck command to substitute templates? + #TODO - deck command to substitute templates? set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] set stripprefix [file normalize $layout_path] @@ -440,7 +440,7 @@ namespace eval punk::mix::commandset::project { if {[llength $templatefiles]} { puts stdout "Filling template file placeholders with the following tag map:" foreach {placeholder value} $tagmap { - puts stdout " $placeholder -> $value" + puts stdout " $placeholder -> $value" } } foreach templatefullpath $templatefiles { @@ -452,7 +452,7 @@ namespace eval punk::mix::commandset::project { set data2 [string map $tagmap $data] if {$data2 ne $data} { puts stdout "updated template file: $fpath" - set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout + set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout } } else { puts stderr "warning: Missing template file $fpath" @@ -464,7 +464,7 @@ namespace eval punk::mix::commandset::project { if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { - #check if mod-ver.tm file or #modpod-mod-ver folder exist + #check if mod-ver.tm file or #modpod-mod-ver folder exist set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm @@ -482,7 +482,7 @@ namespace eval punk::mix::commandset::project { set overwrite_type zip } else { set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] - set overwrite_type $opt_type + set overwrite_type $opt_type } if {[string tolower $answer] eq "y"} { #REVIEW - all pods zip - for now @@ -503,7 +503,7 @@ namespace eval punk::mix::commandset::project { $installer set_source_target $projectdir/src/doc $projectdir/src/embedded set event [$installer start_event {-install_step kettledoc}] $event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source + $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source #---------- if {\ [llength [dict get [$event targetset_source_changes] changed]]\ @@ -535,7 +535,7 @@ namespace eval punk::mix::commandset::project { if {![punk::repo::is_fossil_root $projectdir]} { set first_fossil 1 - #-k = keep. (only modify the manifest file(s)) + #-k = keep. (only modify the manifest file(s)) if {$is_nested_fossil} { set fossilopen [runx -n {*}$fossil_prog open --nested $repodb_folder/$projectname.fossil -k --workdir $projectdir] } else { @@ -600,11 +600,11 @@ namespace eval punk::mix::commandset::project { #[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied #[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s #[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. - #[para]e.g - #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + #[para]e.g + #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection #[para]Will result in the command being available as projects package require overtype - set db_projects [lib::get_projects $glob] + set db_projects [lib::get_projects $glob] set col1items [lsearch -all -inline -index 0 -subindices $db_projects *] set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] @@ -620,15 +620,15 @@ namespace eval punk::mix::commandset::project { set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] set col3 [string repeat " " $widest3] set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] - - + + append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n append msg [string repeat "=" $tablewidth] \n foreach p $col1items n $col2items c $col3items { append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]" \n - } + } return $msg - #return [list_as_lines [lib::get_projects $glob]] + #return [list_as_lines [lib::get_projects $glob]] } proc detail {{glob {}} args} { package require overtype @@ -640,14 +640,14 @@ namespace eval punk::mix::commandset::project { # -- --- --- --- --- --- --- set opt_description [dict get $opts -description] # -- --- --- --- --- --- --- - - set db_projects [lib::get_projects $glob] + + set db_projects [lib::get_projects $glob] set col1_dbfiles [lsearch -all -inline -index 0 -subindices $db_projects *] set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] set col3items [lmap v $checkouts {llength $v}] - + set col4_pnames [list] set col5_pcodes [list] set col6_dupids [list] @@ -658,13 +658,13 @@ namespace eval punk::mix::commandset::project { set project_name "" set project_code "" set project_desc "" - set db_error "" + set db_error "" if {[file exists $dbfile]} { if {[catch { sqlite3 dbp $dbfile dbp eval {select name,value from config where name like 'project-%';} r { if {$r(name) eq "project-name"} { - set project_name $r(value) + set project_name $r(value) } elseif {$r(name) eq "project-code"} { set project_code $r(value) } elseif {$r(name) eq "project-description"} { @@ -687,7 +687,7 @@ namespace eval punk::mix::commandset::project { } incr file_idx } - + set setid 1 set codeset [dict create] dict for {code dbs} $codes { @@ -696,17 +696,17 @@ namespace eval punk::mix::commandset::project { dict set codeset $code count [llength $dbs] dict set codeset $code seen 0 incr setid - } + } } set dupid 1 foreach pc $col5_pcodes { if {[dict exists $codeset $pc]} { - set seen [dict get $codeset $pc seen] + set seen [dict get $codeset $pc seen] set this_seen [expr {$seen + 1}] dict set codeset $pc seen $this_seen - lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" + lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" } else { - lappend col6_dupids "" + lappend col6_dupids "" } } @@ -732,10 +732,10 @@ namespace eval punk::mix::commandset::project { #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $v}]] set widest7 35 set col7 [string repeat " " $widest7] - - + + set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5 + 1 + $widest6}] - + append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]\ [overtype::left $col4 $title4] [overtype::left $col5 $title5] [overtype::left $col6 $title6]" if {!$opt_description} { @@ -747,7 +747,7 @@ namespace eval punk::mix::commandset::project { append msg [string repeat "=" $tablewidth] \n foreach p $col1_dbfiles n $col2items c $col3items pn $col4_pnames pc $col5_pcodes dup $col6_dupids desc $col7_pdescs { - set desclines [split [textutil::adjust $desc -length $widest7] \n] + set desclines [split [textutil::adjust $desc -length $widest7] \n] set desc1 [lindex $desclines 0] append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]\ [overtype::left $col4 $pn] [overtype::left $col5 $pc] [overtype::left $col6 $dup]" @@ -756,20 +756,20 @@ namespace eval punk::mix::commandset::project { } else { append msg " [overtype::left $col7 $desc1]" \n foreach dline [lrange $desclines 1 end] { - append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n + append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n } } - } - return $msg - #return [list_as_lines [lib::get_projects $glob]] + } + return $msg + #return [list_as_lines [lib::get_projects $glob]] } proc cd {{glob {}} args} { dict set args -cd 1 - work $glob {*}$args + work $glob {*}$args } proc work {{glob {}} args} { package require sqlite3 - set db_projects [lib::get_projects $glob] + set db_projects [lib::get_projects $glob] if {[llength $db_projects] == 0} { puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$glob'" return "" @@ -779,22 +779,22 @@ namespace eval punk::mix::commandset::project { set defaults [dict create\ -cd 0\ -detail "\uFFFF"\ - ] + ] set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set opt_cd [dict get $opts -cd] - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set opt_detail [dict get $opts -detail] set opt_detail_explicit_zero 1 ;#default assumption only if {$opt_detail eq "\uFFFF"} { set opt_detail_explicit_zero 0 set opt_detail 0; #default } - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set workdir_dict [dict create] set all_workdirs [list] foreach pinfo $db_projects { - lassign $pinfo fosdb name workdirs + lassign $pinfo fosdb name workdirs foreach wdir $workdirs { dict set workdir_dict $wdir $pinfo lappend all_workdirs $wdir @@ -808,15 +808,15 @@ namespace eval punk::mix::commandset::project { set col_pcodes [list] set col_dupids [list] - set fosdb_count [dict create] + set fosdb_count [dict create] set fosdb_dupset [dict create] set fosdb_cache [dict create] set dupset 0 set rowid 1 foreach wd $workdirs { set wdinfo [dict get $workdir_dict $wd] - lassign $wdinfo fosdb nm siblingworkdirs - dict incr fosdb_count $fosdb + lassign $wdinfo fosdb nm siblingworkdirs + dict incr fosdb_count $fosdb set dbcount [dict get $fosdb_count $fosdb] if {[llength $siblingworkdirs] > 1} { if {![dict exists $fosdb_dupset $fosdb]} { @@ -825,7 +825,7 @@ namespace eval punk::mix::commandset::project { } set dupid "[dict get $fosdb_dupset $fosdb].$dbcount/[llength $siblingworkdirs]" } else { - set dupid "" + set dupid "" } if {$dbcount == 1} { set pname "" @@ -842,7 +842,7 @@ namespace eval punk::mix::commandset::project { puts stderr "!!! error: $errM" } } else { - puts stderr "!!! missing fossil db $fosdb" + puts stderr "!!! missing fossil db $fosdb" } } else { set info [dict get $fosdb_cache $fosdb] @@ -858,7 +858,7 @@ namespace eval punk::mix::commandset::project { set col_states [list] set state_title "" - #if only one set of fossil checkouts in the resultset and opt_detail is 0 and not explicit - retrieve workingdir state for each co + #if only one set of fossil checkouts in the resultset and opt_detail is 0 and not explicit - retrieve workingdir state for each co if {([llength [dict keys $fosdb_cache]] == 1)} { if {!$opt_detail_explicit_zero} { set opt_detail 1 @@ -884,13 +884,13 @@ namespace eval punk::mix::commandset::project { set state_dict [punk::repo::workingdir_state_summary_dict $wd_state] lappend c_rev [string range [dict get $state_dict revision] 0 9] lappend c_rev_iso [dict get $state_dict revision_iso8601] - lappend c_unchanged [dict get $state_dict unchanged] + lappend c_unchanged [dict get $state_dict unchanged] lappend c_changed [dict get $state_dict changed] lappend c_new [dict get $state_dict new] lappend c_missing [dict get $state_dict missing] lappend c_extra [dict get $state_dict extra] puts -nonewline stderr "." - } + } puts -nonewline stderr \n set t0 "Revision" set w0 [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev] {string length $v}]] @@ -913,13 +913,13 @@ namespace eval punk::mix::commandset::project { set t5 "Extr" set w5 [tcl::mathfunc::max {*}[lmap v [concat [list $t5] $c_extra] {string length $v}]] set c5 [string repeat " " $w5] - + set state_title "[overtype::left $c0 $t0] [overtype::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [overtype::right $c1 $u] [overtype::right $c2 $c] [overtype::right $c3 $n] [overtype::right $c4 $m] [overtype::right $c5 $e]" } } - + set msg "" if {$opt_cd} { set title0 "CD" @@ -948,7 +948,7 @@ namespace eval punk::mix::commandset::project { append msg "[overtype::right $col0 $title0] [overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3] [overtype::left $col4 $title4] [overtype::left $col5 $title5]" if {[llength $col_states]} { - set title6 $state_title + set title6 $state_title set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col_states] {string length $v}]] set col6 [string repeat " " $widest6] incr tablewidth [expr {$widest6 + 1}] @@ -965,7 +965,7 @@ namespace eval punk::mix::commandset::project { set wd [punk::ansi::a+ red]$wd[a] } append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode] [overtype::left $col6 $s]" \n - } + } } else { foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes { if {![file exists $wd]} { @@ -973,7 +973,7 @@ namespace eval punk::mix::commandset::project { set wd [punk::ansi::a+ red]$wd[a] } append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode]" \n - } + } } set numrows [llength $col_rowids] if {$opt_cd && $numrows >= 1} { @@ -985,7 +985,7 @@ namespace eval punk::mix::commandset::project { ::cd $workingdir return $workingdir } else { - puts stderr "path $workingdir doesn't appear to exist" + puts stderr "path $workingdir doesn't appear to exist" return [pwd] } } else { @@ -1004,12 +1004,12 @@ namespace eval punk::mix::commandset::project { #*** !doctools #[list_end] [comment {-- end collection namespace definitions --}] } - + namespace eval lib { proc template_tag {tagname} { #todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. #we need to detect presence of tags intended for punk::mix system - #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run + #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run return [string cat % $tagname %] } #get project info only by opening the central confg-db @@ -1032,12 +1032,13 @@ namespace eval punk::mix::commandset::project { set path [string trim [string range $pr 5 end]] set nm [file rootname [file tail $path]] set ckouts [fosconf eval {select name from global_config where value = $path;}] + #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" set checkout_paths [list] #strip "ckout:" foreach ck $ckouts { lappend checkout_paths [string trim [string range $ck 6 end]] } - lappend paths_and_names [list $path $nm $checkout_paths] + lappend paths_and_names [list $path $nm $checkout_paths] } set filtered_list [list] foreach glob $globlist { @@ -1045,16 +1046,14 @@ namespace eval punk::mix::commandset::project { foreach m $matches { if {$m ni $filtered_list} { lappend filtered_list $m - } + } } } set projects [lsort -index 1 $filtered_list] return $projects } - + } - - @@ -1067,15 +1066,10 @@ namespace eval punk::mix::commandset::project { - - - - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm index 73b54874..277e386e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm @@ -24,6 +24,9 @@ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::mix::commandset::repo { namespace export * + + variable PUNKARGS + proc tickets {{project ""}} { #todo set result "" @@ -52,9 +55,9 @@ namespace eval punk::mix::commandset::repo { set repopaths [punk::repo::find_repos [pwd]] set repos [dict get $repopaths repos] if {![llength $repos]} { - append result [dict get $repopaths warnings] + append result [a+ bold yellow][dict get $repopaths warnings][a] } else { - append result [dict get $repopaths warnings] + append result [a+ bold yellow][dict get $repopaths warnings][a] lassign [lindex $repos 0] repopath repotypes if {"fossil" in $repotypes} { append result \n "Fossil repo based at $repopath" @@ -69,6 +72,17 @@ namespace eval punk::mix::commandset::repo { } return $result } + + #punk::args + lappend PUNKARGS [list { + @id -id ::punk::mix::commandset::repo::fossil-move-repository + @cmd -name punk::mix::commandset::repo::fossil-move-repository -help\ + "Move the fossil repository file (usually named with .fossil extension). + This is an interactive function which will prompt for answers on stdin + before proceeding. + The move can be done even if there are open checkouts and will maintain + the link between checkout databases and the repository file." + }] proc fossil-move-repository {{path ""}} { set searchbase [pwd] set projectinfo [punk::repo::find_repos $searchbase] @@ -281,7 +295,7 @@ namespace eval punk::mix::commandset::repo { set ckouts [oldrepo eval {select name from config where name like 'ckout:%'}] oldrepo close if {[llength $ckouts] > 1} { - puts stdout "There are [llength $ckouts] checkouts for the repository you are moving" + puts stdout "There are [llength $ckouts] checkouts for the repository you are moving" puts stdout "You will be asked for each checkout if you want to adjust it to point to $target_repodb_folder/$pname2.folder" } set original_cwd [pwd] @@ -304,11 +318,11 @@ namespace eval punk::mix::commandset::repo { puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" puts stderr "$moveresult" } else { - puts stdout "OK - move performed with result:" + puts stdout "OK - move performed with result:" puts stdout $moveresult } } - } + } cd $original_cwd } @@ -379,7 +393,7 @@ namespace eval punk::mix::commandset::repo { puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" puts stderr "$moveresult" } else { - puts stdout "OK - move performed with result:" + puts stdout "OK - move performed with result:" puts stdout $moveresult } } @@ -402,10 +416,10 @@ namespace eval punk::mix::commandset::repo { - - - - +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::mix::commandset::repo +} @@ -413,9 +427,9 @@ namespace eval punk::mix::commandset::repo { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.tm index 58906c88..26ed2f2e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.tm @@ -1,164 +1,163 @@ -#punkapps app manager -# deck cli - -namespace eval punk::mod::cli { - namespace export help list run - namespace ensemble create - - # namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown - if 0 { - proc _unknown {ns args} { - puts stderr "punk::mod::cli::_unknown '$ns' '$args'" - puts stderr "punk::mod::cli::help $args" - puts stderr "arglen:[llength $args]" - punk::mod::cli::help {*}$args - } - } - - #cli must have _init method - usually used to load commandsets lazily - # - variable initialised 0 - proc _init {args} { - variable initialised - if {$initialised} { - return - } - #... - set initialised 1 - } - - proc help {args} { - set basehelp [punk::mix::base help {*}$args] - #namespace export - return $basehelp - } - proc getraw {appname} { - upvar ::punk::config::running running_config - set app_folders [dict get $running_config apps] - #todo search each app folder - set bases [::list] - set versions [::list] - set mains [::list] - set appinfo [::list bases {} mains {} versions {}] - - foreach containerfolder $app_folders { - lappend bases $containerfolder - if {[file exists $containerfolder]} { - if {[file exists $containerfolder/$appname/main.tcl]} { - #exact match - only return info for the exact one specified - set namematches $appname - set parts [split $appname -] - } else { - set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] - set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? - } - foreach nm $namematches { - set mainfile $containerfolder/$nm/main.tcl - set parts [split $nm -] - if {[llength $parts] == 1} { - set ver "" - } else { - set ver [lindex $parts end] - } - if {$ver ni $versions} { - lappend versions $ver - lappend mains $ver $mainfile - } else { - puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" - } - } - } else { - puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" - } - } - dict set appinfo versions $versions - #todo - natsort! - set sorted_versions [lsort $versions] - set latest [lindex $sorted_versions 0] - if {$latest eq "" && [llength $sorted_versions] > 1} { - set latest [lindex $sorted_versions 1 - } - dict set appinfo latest $latest - - dict set appinfo bases $bases - dict set appinfo mains $mains - return $appinfo - } - - proc list {{glob *}} { - upvar ::punk::config::running running_config - set apps_folder [dict get $running_config apps] - if {[file exists $apps_folder]} { - if {[file exists $apps_folder/$glob]} { - #tailcall source $apps_folder/$glob/main.tcl - return $glob - } - set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] - if {[llength $apps] == 0} { - if {[string first * $glob] <0 && [string first ? $glob] <0} { - #no glob chars supplied - only launch if exact match for name part - set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] - set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? - if {[llength $namematches] > 0} { - set latest [lindex $namematches end] - lassign $latest nm ver - #tailcall source $apps_folder/$latest/main.tcl - } - } - } - - return $apps - } - } - - #todo - way to launch as separate process - # solo-opts only before appname - args following appname are passed to the app - proc run {args} { - set nameposn [lsearch -not $args -*] - if {$nameposn < 0} { - error "punkapp::run unable to determine application name" - } - set appname [lindex $args $nameposn] - set controlargs [lrange $args 0 $nameposn-1] - set appargs [lrange $args $nameposn+1 end] - - set appinfo [punk::mod::cli::getraw $appname] - if {[llength [dict get $appinfo versions]]} { - set ver [dict get $appinfo latest] - puts stdout "info: $appinfo" - set ::argc [llength $appargs] - set ::argv $appargs - source [dict get $appinfo mains $ver] - if {"-hideconsole" in $controlargs} { - puts stderr "attempting console hide" - #todo - something better - a callback when window mapped? - after 500 {::punkapp::hide_console} - } - return $appinfo - } else { - error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" - } - } - - -} - -namespace eval punk::mod::cli { - proc _cli {args} { - #don't use tailcall - base uses info level to determine caller - ::punk::mix::base::_cli {*}$args - } - variable default_command help - package require punk::mix::base - package require punk::overlay - punk::overlay::custom_from_base [namespace current] ::punk::mix::base -} - -package provide punk::mod [namespace eval punk::mod { - variable version - set version 0.1 - -}] - - - +#punkapps app manager +# deck cli + +namespace eval punk::mod::cli { + namespace export help list run + namespace ensemble create + + # namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown + if 0 { + proc _unknown {ns args} { + puts stderr "punk::mod::cli::_unknown '$ns' '$args'" + puts stderr "punk::mod::cli::help $args" + puts stderr "arglen:[llength $args]" + punk::mod::cli::help {*}$args + } + } + + #cli must have _init method - usually used to load commandsets lazily + # + variable initialised 0 + proc _init {args} { + variable initialised + if {$initialised} { + return + } + #... + set initialised 1 + } + + proc help {args} { + set basehelp [punk::mix::base help {*}$args] + #namespace export + return $basehelp + } + proc getraw {appname} { + upvar ::punk::config::running running_config + set app_folders [dict get $running_config apps] + #todo search each app folder + set bases [::list] + set versions [::list] + set mains [::list] + set appinfo [::list bases {} mains {} versions {}] + + foreach containerfolder $app_folders { + lappend bases $containerfolder + if {[file exists $containerfolder]} { + if {[file exists $containerfolder/$appname/main.tcl]} { + #exact match - only return info for the exact one specified + set namematches $appname + set parts [split $appname -] + } else { + set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + } + foreach nm $namematches { + set mainfile $containerfolder/$nm/main.tcl + set parts [split $nm -] + if {[llength $parts] == 1} { + set ver "" + } else { + set ver [lindex $parts end] + } + if {$ver ni $versions} { + lappend versions $ver + lappend mains $ver $mainfile + } else { + puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" + } + } + } else { + puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" + } + } + dict set appinfo versions $versions + #todo - natsort! + set sorted_versions [lsort $versions] + set latest [lindex $sorted_versions 0] + if {$latest eq "" && [llength $sorted_versions] > 1} { + set latest [lindex $sorted_versions 1] + } + dict set appinfo latest $latest + + dict set appinfo bases $bases + dict set appinfo mains $mains + return $appinfo + } + + proc list {{glob *}} { + upvar ::punk::config::running running_config + set apps_folder [dict get $running_config apps] + if {[file exists $apps_folder]} { + if {[file exists $apps_folder/$glob]} { + #tailcall source $apps_folder/$glob/main.tcl + return $glob + } + set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] + if {[llength $apps] == 0} { + if {[string first * $glob] <0 && [string first ? $glob] <0} { + #no glob chars supplied - only launch if exact match for name part + set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + if {[llength $namematches] > 0} { + set latest [lindex $namematches end] + lassign $latest nm ver + #tailcall source $apps_folder/$latest/main.tcl + } + } + } + + return $apps + } + } + + #todo - way to launch as separate process + # solo-opts only before appname - args following appname are passed to the app + proc run {args} { + set nameposn [lsearch -not $args -*] + if {$nameposn < 0} { + error "punkapp::run unable to determine application name" + } + set appname [lindex $args $nameposn] + set controlargs [lrange $args 0 $nameposn-1] + set appargs [lrange $args $nameposn+1 end] + + set appinfo [punk::mod::cli::getraw $appname] + if {[llength [dict get $appinfo versions]]} { + set ver [dict get $appinfo latest] + puts stdout "info: $appinfo" + set ::argc [llength $appargs] + set ::argv $appargs + source [dict get $appinfo mains $ver] + if {"-hideconsole" in $controlargs} { + puts stderr "attempting console hide" + #todo - something better - a callback when window mapped? + after 500 {::punkapp::hide_console} + } + return $appinfo + } else { + error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" + } + } + + +} + +namespace eval punk::mod::cli { + proc _cli {args} { + #don't use tailcall - base uses info level to determine caller + ::punk::mix::base::_cli {*}$args + } + variable default_command help + package require punk::mix::base + package require punk::overlay + punk::overlay::custom_from_base [namespace current] ::punk::mix::base +} + +package provide punk::mod [namespace eval punk::mod { + variable version + set version 0.1 +}] + + + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index f0a4a444..1ddd56b7 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -657,6 +657,7 @@ namespace eval punk::path { **/_aside (exlude files where _aside is last segment) **/_aside/* (exclude folders one below an _aside folder) **/_aside/** (exclude all folders with _aside as a segment)" + -antiglob_files -default {} @values -min 0 -max -1 -optional 1 -type string tailglobs -default * -multiple 1 -help\ "Patterns to match against filename portion (last segment) of each file path @@ -681,6 +682,7 @@ namespace eval punk::path { set tailglobs [dict get $values tailglobs] # -- --- --- --- --- --- --- set opt_antiglob_paths [dict get $opts -antiglob_paths] + set opt_antiglob_files [dict get $opts -antiglob_files] set CALLDEPTH [dict get $opts -call-depth-internal] # -- --- --- --- --- --- --- # -- --- --- --- --- --- --- @@ -718,7 +720,24 @@ namespace eval punk::path { puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" set dirfiles [list] } else { - set dirfiles [lsort $matches] + set retained [list] + if {[llength $opt_antiglob_files]} { + foreach m $matches { + set skip 0 + set ftail [file tail $m] + foreach anti $opt_antiglob_files { + if {[string match $anti $ftail]} { + set skip 1; break + } + } + if {!$skip} { + lappend retained $m + } + } + } else { + set retained $matches + } + set dirfiles [lsort $retained] } lappend files {*}$dirfiles diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index f53a06fd..a39fceaf 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -39,16 +39,16 @@ if {$::tcl_platform(platform) eq "windows"} { } package require fileutil; #tcllib package require punk::path -package require punk::mix::base ;#uses core functions from punk::mix::base::lib namespace e.g cksum_path +package require punk::mix::base ;#uses core functions from punk::mix::base::lib namespace e.g cksum_path package require punk::mix::util ;#do_in_path # -- --- --- --- --- --- --- --- --- --- --- # For performance/efficiency reasons - use file functions on paths in preference to string operations -# e.g use file join +# e.g use file join # branch to avoid unnecessary calls to 'pwd' or 'file normalize' - which can be surprisingly expensive operations (as at tcl 8.7 2023) # pwd is only expensive if we treat it as a string instead of a list/path -# e.g +# e.g # > time {set x [pwd]} # 5 microsoeconds.. no problem # > time {set x [pwd]} @@ -67,11 +67,11 @@ namespace eval punk::repo { variable cached_command_paths set cached_command_paths [dict create] - #anticipating possible removal of buggy caching from auto_execok + #anticipating possible removal of buggy caching from auto_execok #mentioned in: https://core.tcl-lang.org/tcl/tktview/4dc35e0c0c #this would leave the application to decide what it wants to cache in that regard. proc Cached_auto_execok {name} { - return [auto_execok $name] + return [auto_execok $name] #variable cached_command_paths #if {[dict exists $cached_command_paths $name]} { # return [dict get $cached_command_paths $name] @@ -102,14 +102,14 @@ namespace eval punk::repo { "" {${$othercmds}} } }] - + return $result } #lappend PUNKARGS [list { # @dynamic - # @id -id ::punk::repo::fossil_proxy + # @id -id ::punk::repo::fossil_proxy # @cmd -name fossil -help "fossil executable # " # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} @@ -117,7 +117,7 @@ namespace eval punk::repo { lappend PUNKARGS [list { @dynamic - @id -id ::punk::repo::fossil_proxy + @id -id ::punk::repo::fossil_proxy @cmd -name fossil -help "fossil executable" ${[punk::repo::get_fossil_usage]} } ] @@ -128,14 +128,13 @@ namespace eval punk::repo { lappend PUNKARGS [list { @dynamic @id -id "::punk::repo::fossil_proxy diff" - @cmd -name "fossil diff" -help "fossil diff - " + @cmd -name "fossil diff" -help "fossil diff" @argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} } ""] lappend PUNKARGS [list { #todo - remove this comment - testing dynamic directive - @dynamic - @id -id "::punk::repo::fossil_proxy add" + @dynamic + @id -id "::punk::repo::fossil_proxy add" @cmd -name "fossil add" -help "fossil add " @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} @@ -152,16 +151,16 @@ namespace eval punk::repo { lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} - #Todo - investigate proper way to install a client-side commit hook in the fossil project + #Todo - investigate proper way to install a client-side commit hook in the fossil project #Then we may still use this proxy to check the hook - but the required checks will occur when another shell used proc fossil_proxy {args} { set start_dir [pwd] - set fosroot [find_fossil $start_dir] + set fosroot [find_fossil $start_dir] set fossilcmd [lindex $args 0] set no_warning_commands [list "help" "dbstat" "grep" "diff" "xdiff" "cat" "version"] if {$fossilcmd ni $no_warning_commands } { - set repostate [find_repos $start_dir] + set repostate [find_repos $start_dir] } set no_prompt_commands [list "status" "info" {*}$no_warning_commands] @@ -170,7 +169,7 @@ namespace eval punk::repo { if {$fossilcmd ni $no_prompt_commands} { set fossilrepos [dict get $repostate fossil] if {[llength $fossilrepos] > 1} { - puts stdout [dict get $repostate warnings] + puts stdout [punk::ansi::a+ bold yellow][dict get $repostate warnings][punk::ansi::a] puts stdout "Operating on inner fossil repository: [lindex $fossilrepos 0]" puts stdout "Use FOSSIL instead of fossil to avoid this prompt and warning" set answer [askuser "Are you sure you want to perform the operation on this repo? Y/N"] @@ -217,7 +216,7 @@ namespace eval punk::repo { } } elseif {$fossilcmd in [list "info" "status"]} { #emit warning whether or not multiple fossil repos - puts stdout [dict get $repostate warnings] + puts stdout [punk::ansi::a+ bold yellow][dict get $repostate warnings][punk::ansi::a] } set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog ne ""} { @@ -234,7 +233,7 @@ namespace eval punk::repo { #safe interps can't call auto_execok #At least let them load the package even though much of it may be unusable depending on the safe configuration #catch { - # if {[auto_execok fossil] ne ""} { + # if {[auto_execok fossil] ne ""} { # interp alias "" FOSSIL "" {*}[auto_execok fossil] # } #} @@ -245,7 +244,7 @@ namespace eval punk::repo { #uppercase FOSSIL to bypass fossil as alias to fossil_proxy #only necessary on unix? - #Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway + #Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway proc establish_FOSSIL {args} { #review if {![info exists ::auto_execs(FOSSIL)]} { @@ -298,7 +297,7 @@ namespace eval punk::repo { if {$path eq {}} { set path [pwd] } scanup $path is_fossil_root } - + proc find_git {{path {}}} { if {$path eq {}} { set path [pwd] } scanup $path is_git_root @@ -330,12 +329,31 @@ namespace eval punk::repo { } } } + lappend PUNKARGS [list { + @id -id "::punk::repo::find_project" + @cmd -name "punk::repo::find_project" -help\ + "Find and return the path for the root of + the project to which the supplied path belongs. + If the supplied path is empty, the current + working directory is used as the starting point + for the upwards search. + Returns nothing if there is no project at or + above the specified path." + @values -min 0 -max 1 + path -optional 1 -default "" -help\ + "May be an absolute or relative path. + The full specified path doesn't have + to exist. The code will walk upwards + along the segments of the supplied path + testing the result of 'is_project_root'." + }] proc find_project {{path {}}} { if {$path eq {}} { set path [pwd] } - scanup $path is_project_root + scanup $path is_project_root } - proc is_fossil_root {{path {}}} { + #detect if path is a fossil root - without consulting fossil databases + proc is_fossil_root2 {{path {}}} { if {$path eq {}} { set path [pwd] } #from kettle::path::is.fossil foreach control { @@ -348,20 +366,51 @@ namespace eval punk::repo { } return 0 } - + proc is_fossil_root {{path {}}} { + #much faster on windows than 'file exists' checks + if {$path eq {}} { set path [pwd] } + set control [list _FOSSIL_ .fslckout .fos] + #could be marked 'hidden' on windows + if {"windows" eq $::tcl_platform(platform)} { + set files [list {*}[glob -nocomplain -dir $path -types f -tail {*}$control] {*}[glob -nocomplain -dir $path -types {f hidden} -tail {*}$control]] + } else { + set files [glob -nocomplain -dir $path -types f -tail {*}$control] + } + expr {[llength $files] > 0} + } + #review - is a .git folder sufficient? #consider git rev-parse --git-dir ? proc is_git_root {{path {}}} { if {$path eq {}} { set path [pwd] } - set control [file join $path .git] - expr {[file exists $control] && [file isdirectory $control]} + #set control [file join $path .git] + #expr {[file exists $control] && [file isdirectory $control]} + if {"windows" eq $::tcl_platform(platform)} { + #:/ + #globbing for dotfiles in tcl is problematic across platforms - windows 'hidden' concept is independent + #we need to find .git whether hidden or not - so need 2 glob operations + #.git may or may not be set with windows 'hidden' attribute + set hiddengitdir [glob -nocomplain -dir $path -types {d hidden} -tail .git] + set nonhiddengitdir [glob -nocomplain -dir $path -types {d} -tail .git] ;#won't return hidden :/ + return [expr {[llength [list {*}$hiddengitdir {*}$nonhiddengitdir]] > 0}] + } else { + #:/ + #unix returns 'hidden' files even without the hidden type being specified - but only if the pattern explicitly matches + return [expr {[llength [glob -nocomplain -dir $path -types d -tail .git]] > 0}] ;#will return .git even though it is conventionally 'hidden' on unix :/ + } } proc is_repo_root {{path {}}} { if {$path eq {}} { set path [pwd] } - expr {[is_fossil_root $path] || [is_git_root $path]} + #expr {[is_fossil_root $path] || [is_git_root $path]} + expr {[is_git_root $path] || [is_fossil_root $path]} ;#is_git_root has less to check } - #require a minimum of src and src/modules|src/scriptapps|src/*/*.vfs - and that it's otherwise sensible - #we still run a high chance of picking up unintended candidates - but hopefully it's a reasonable balance. + + #after excluding undesirables; + #require a minimum of + # - (src and src/modules|src/scriptapps|src/vfs) + # - OR (src and punkproject.toml) + # - and that it's otherwise sensible + #we still run a chance of picking up unintended candidates - but hopefully it's a reasonable balance. proc is_candidate_root {{path {}}} { if {$path eq {}} { set path [pwd] } if {[file pathtype $path] eq "relative"} { @@ -380,24 +429,34 @@ namespace eval punk::repo { } #review - adjust to allow symlinks to folders? - foreach required { - src - } { - set req $path/$required - if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0} + #foreach required { + # src + #} { + # set req $path/$required + # if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0} + #} + set required [list src] + set found_required [glob -nocomplain -dir $path -types d -tails {*}$required] + if {[llength $found_required] < [llength $required]} { + return 0 } set src_subs [glob -nocomplain -dir $path/src -types d -tail *] #test for $path/src/lib is too common to be a useful indicator - if {"modules" in $src_subs || "scriptapps" in $src_subs} { + if {"modules" in $src_subs || "vfs" in $src_subs || "scriptapps" in $src_subs} { + #bare minimum 1 return 1 } - foreach sub $src_subs { - if {[string match *.vfs $sub]} { - return 1 - } + + #bare minimum2 + # - has src folder and (possibly empty?) punkproject.toml + if {[file exists $path/punkproject.toml]} { + return 1 } + #review - do we need to check if path is already within a project? + #can we have a nested project? Seems like asking for complexity and problems when considering possible effects for git/fossil + #todo - breadth first search with depth limit (say depth 3?) for *.tm or *.tcl as another positive qualifier for this dir to be a project-root #we probably don't want to deep search a src folder in case the user is accidentally in some other type of project's tree #such a src tree could be very large, so if we don't find tcl indicators near the root it's a good bet this isn't a candidate @@ -415,14 +474,22 @@ namespace eval punk::repo { } proc is_project_root {path} { - #review - find a reliable simple mechanism. Noting we have projects based on different templates. + #review - find a reliable simple mechanism. Noting we have projects based on different templates. #Should there be a specific required 'project' file of some sort? + #(punkproject.toml is a candidate) + #we don't want to solely rely on such a file being present + # - we may also have punkproject.toml in project_layout template folders for example #test for file/folder items indicating fossil or git workdir base - if {(![punk::repo::is_fossil_root $path]) && (![punk::repo::is_git_root $path])} { + #the 'dev' mechanism for creating projects automatically creates a fossil project + #(which can be ignored if the user wants to manage it with git - but should probably remain in place? review) + #however - we currently require that for it to be a 'project' there must be some version control. + #REVIEW. + # + if {![punk::repo::is_repo_root $path]} { return 0 } - #exclude some known places we wouldn't want to put a project + #exclude some known places we wouldn't want to put a project if {![is_candidate_root $path]} { return 0 } @@ -456,7 +523,7 @@ namespace eval punk::repo { if {$abspath in [dict keys $defaults]} { set args [list $abspath {*}$args] set abspath "" - } + } set opts [dict merge $defaults $args] # -- --- --- --- --- --- --- --- --- --- --- --- set opt_repotypes [dict get $opts -repotypes] @@ -793,7 +860,7 @@ namespace eval punk::repo { } } if {$repotype eq "git"} { - dict set fieldnames extra "extra (files/folders)" + dict set fieldnames extra "extra (files/folders)" } set col1_fields [list] set col2_values [list] @@ -846,6 +913,7 @@ namespace eval punk::repo { #determine nature of possibly-nested repositories (of various types) at and above this path #Treat an untracked 'candidate' folder as a sort of repository proc find_repos {path} { + puts "find_repos '$path'" set start_dir $path #root is a 'project' if it it meets the candidate requrements and is under repo control @@ -860,6 +928,10 @@ namespace eval punk::repo { while {[string length [set fosroot [punk::repo::find_fossil $fos_search_from]]]} { lappend fossils_bottom_to_top $fosroot set fos_search_from [file dirname $fosroot] + if {$fos_search_from eq $fosroot} { + #root of filesystem is repo - unusual case - but without this we would never escape the while loop + break + } } dict set root_dict fossil $fossils_bottom_to_top @@ -868,6 +940,9 @@ namespace eval punk::repo { while {[string length [set gitroot [punk::repo::find_git $git_search_from]]]} { lappend gits_bottom_to_top $gitroot set git_search_from [file dirname $gitroot] + if {$git_search_from eq $gitroot} { + break + } } dict set root_dict git $gits_bottom_to_top @@ -876,6 +951,9 @@ namespace eval punk::repo { while {[string length [set candroot [punk::repo::find_candidate $cand_search_from]]]} { lappend candidates_bottom_to_top $candroot set cand_search_from [file dirname $candroot] + if {$cand_search_from eq $candroot} { + break + } } dict set root_dict candidate $candidates_bottom_to_top @@ -936,14 +1014,14 @@ namespace eval punk::repo { dict set root_dict closest [lindex $longest_first 0 1] ;#the *path* of the closest to start_dir dict set root_dict closest_types [lindex $longest_first 0 0] } - - set closest_fossil [lindex [dict get $root_dict fossil] 0] - set closest_fossil_len [llength [file split $closest_fossil]] - set closest_git [lindex [dict get $root_dict git] 0] - set closest_git_len [llength [file split $closest_git]] - set closest_candidate [lindex [dict get $root_dict candidate] 0] - set closest_candidate_len [llength [file split $closest_candidate]] + + set closest_fossil [lindex [dict get $root_dict fossil] 0] + set closest_fossil_len [llength [file split $closest_fossil]] + set closest_git [lindex [dict get $root_dict git] 0] + set closest_git_len [llength [file split $closest_git]] + set closest_candidate [lindex [dict get $root_dict candidate] 0] + set closest_candidate_len [llength [file split $closest_candidate]] if {$closest_candidate_len > $closest_fossil_len && $closest_candidate_len > $closest_git_len} { #only warn if this candidate is *within* a found repo root @@ -1079,7 +1157,7 @@ namespace eval punk::repo { } if {$opt_ansi} { if {$opt_ansi_prompt eq "\uFFFF"} { - set ansiprompt [a+ green bold] + set ansiprompt [a+ green bold] } else { set ansiprompt [$opt_ansi_prompt] } @@ -1112,15 +1190,15 @@ namespace eval punk::repo { #Whilst it might detect a central repo folder in a non-standard location - it might also be annoying. #Todo - a separate environment variable for users to declare one or more locations where they would like to store project .fossil repositories? - set candidate_repo_folder_locations [list] + set candidate_repo_folder_locations [list] #- choose a sensible default based on where fossil put the global config dir - or on the existence of a .fossils folder in a 'standard' location #verify with user before creating a .fossils folder #always check env(FOSSIL_HOME) first - but this is designed to locate the global .fossil (or _fossil) file - .fossils repository folder doesn't have to be at the same location set usable_repo_folder_locations [list] - #If we find one, but it's not writable - add it to another list + #If we find one, but it's not writable - add it to another list set readonly_repo_folder_locations [list] - #Examine a few possible locations for .fossils folder set + #Examine a few possible locations for .fossils folder set #if containing folder is writable add to candidate list set testpaths [list] @@ -1129,8 +1207,8 @@ namespace eval punk::repo { if {![catch {package require Tcl 8.7-}]} { set fossilhome [file normalize [file tildeexpand $fossilhome_raw]] } else { - #8.6 - set fossilhome [file normalize $fossilhome_raw] + #8.6 + set fossilhome [file normalize $fossilhome_raw] } lappend testpaths [file join $fossilhome .fossils] @@ -1175,13 +1253,13 @@ namespace eval punk::repo { } } } - + set startdir_fossils [glob -nocomplain -dir $startdir -type f *.fossil] if {[llength $startdir_fossils]} { #user is already keeping .fossil files directly in curent dir - give them the option to easily keep doing this #(we don't add it if no .fossil files there already - as it is probably a niche requirement - or a sign the user hasn't thought about a better/central location) if {$startdir ni $usable_repo_folder_locations} { - lappend usable_repo_folder_locations $startdir + lappend usable_repo_folder_locations $startdir } } set choice_folders [list] @@ -1207,7 +1285,7 @@ namespace eval punk::repo { #no existing writable .fossil folders (and no existing .fossil files in startdir) #offer the (writable) candidate_repo_folder_locations foreach fld $candidate_repo_folder_locations { - lappend choice_folders [list index $i folder $fld folderexists 0 existingfossils "" conflict ""] + lappend choice_folders [list index $i folder $fld folderexists 0 existingfossils "" conflict ""] incr i } } @@ -1230,7 +1308,7 @@ namespace eval punk::repo { } set folderexists [dict get $option folderexists] if {$folderexists} { - set folderstatus "(existing folder)" + set folderstatus "(existing folder)" } else { set folderstatus "(CREATE folder for .fossil repository files)" } @@ -1238,7 +1316,7 @@ namespace eval punk::repo { } - #append the readonly_repo_folder_locations so that user is aware of them as it may affect their choice + #append the readonly_repo_folder_locations so that user is aware of them as it may affect their choice if {[llength $readonly_repo_folder_locations]} { append menu_message "--------------------------------------------------" \n foreach readonly $readonly_repo_folder_locations { @@ -1256,11 +1334,11 @@ namespace eval punk::repo { } else { if {[llength $choice_folders] || $opt_askpath} { puts stdout $menu_message - set max [llength $choice_folders] + set max [llength $choice_folders] if {$max == 1} { set rangemsg "the number 1" } else { - set rangemsg "a number from 1 to $max" + set rangemsg "a number from 1 to $max" } set menuprompt "${ansiprompt}Enter $rangemsg to select location. (or N to abort)${ansireset}" if {$opt_askpath} { @@ -1279,7 +1357,7 @@ namespace eval punk::repo { set answer [askuser "${ansiprompt}Do you want to create this folder? Type just the word mkdir to create it, or N for no${ansireset}"] if {[string equal mkdir [string tolower $answer]]} { if {[catch {file mkdir $repository_folder} errM]} { - puts stderr "Failed to create folder $repository_folder. Error $errM" + puts stderr "Failed to create folder $repository_folder. Error $errM" } } } else { @@ -1317,7 +1395,7 @@ namespace eval punk::repo { if {$index >= 0 && $index <= $max-1} { set repo_folder_choice [lindex $choice_folders $index] set repository_folder [dict get $repo_folder_choice folder] - puts stdout "Selected fossil location $repository_folder" + puts stdout "Selected fossil location $repository_folder" } else { puts stderr " No menu number matched - aborting." return @@ -1367,7 +1445,7 @@ namespace eval punk::repo { proc fossil_revision {{path {}}} { if {$path eq {}} { set path [pwd] } - # ::kettle::path::revision.fossil + # ::kettle::path::revision.fossil set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { @@ -1381,7 +1459,7 @@ namespace eval punk::repo { proc fossil_remote {{path {}}} { if {$path eq {}} { set path [pwd] } - # ::kettle::path::revision.fossil + # ::kettle::path::revision.fossil set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { @@ -1395,11 +1473,11 @@ namespace eval punk::repo { proc fossil_get_configdb {{path {}}} { #fossil info will *usually* give us the necessary config-db info whether in a project folder or not but.. #a) It's expensive to shell-out and call it - #b) it won't give us a result if we are in a checkout folder which has had its repository moved + #b) it won't give us a result if we are in a checkout folder which has had its repository moved #this fairly extensive mechanism is designed to find it even if the environment has some weird goings-on regarding the filesystem/environment variables #This is unlikely to be necessary in most scenarios, where the location is related to the user's home directory - - #attempt 1 - environment vars and well-known locations + + #attempt 1 - environment vars and well-known locations #This is first because it's faster - but hopefully it's aligned with how fossil does it if {"windows" eq $::tcl_platform(platform)} { @@ -1416,7 +1494,7 @@ namespace eval punk::repo { if {[file exists $testfile]} { return $testfile } - } + } } else { foreach varname [list FOSSIL_HOME HOME ] { if {[info exists ::env($varname)]} { @@ -1435,13 +1513,13 @@ namespace eval punk::repo { if {[file exists $testfile]} { return $testfile } - } + } if {[info exists ::env(HOME)]} { set testfile [file join $::env(HOME) .config fossil.db] if {[file exists $testfile]} { return $testfile } - } + } } @@ -1484,13 +1562,13 @@ namespace eval punk::repo { cd $original_cwd } - #attempt 3 - getting desperate.. find other repos, determine their checkouts and run fossil in them to get a result + #attempt 3 - getting desperate.. find other repos, determine their checkouts and run fossil in them to get a result if {$fossil_ok} { #It should be extremely rare to need to resort to sqlite on the databases to find other potential repo paths #Conceivably only on some weird VFS or where some other filesystem strangeness is going on with our original path - or if the root volume itself is a broken fossil checkout #Examining the other repos gives us a chance at discovering some other filesystem/paths where things may not be broken if {![catch {package require sqlite3} errPackage]} { - #use fossil all ls and sqlite + #use fossil all ls and sqlite if {[catch {exec {*}$fossilcmd all ls} repolines]} { error "fossil_get_configdb cannot find repositories" } else { @@ -1535,7 +1613,7 @@ namespace eval punk::repo { error "fossil_get_configdb exhausted search options" } #------------------------------------ - + #temporarily cd to workpath to run script - return to correct path even on failure proc do_in_path {path script} { #from ::kettle::path::in @@ -1611,8 +1689,8 @@ namespace eval punk::repo { set platform $::tcl_platform(platform) } - #No - don't do this sort of path translation here - leave as option for specific utils only such as ./ - #Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work + #No - don't do this sort of path translation here - leave as option for specific utils only such as ./ + #Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work #We shouldn't break it totally just because accessing WSL/mingw paths is slightly more useful #if {$platform eq "windows"} { #return [file dirname [file normalize [punk::unixywindows::towinpath $path]/__]] @@ -1624,7 +1702,7 @@ namespace eval punk::repo { #This taken from kettle::path::strip #It doesn't compare the prefix contents presumably for speed when used in kettle::path::scan #renamed to better indicate its behaviour - + proc path_strip_prefixdepth {path prefix} { if {$prefix eq ""} { return [norm $path] @@ -1713,9 +1791,9 @@ namespace eval ::punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::repo [namespace eval punk::repo { variable version - set version 0.1.1 + set version 0.1.1 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkapp-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkapp-0.1.tm index ce46856b..70fa90fc 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkapp-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkapp-0.1.tm @@ -1,239 +1,239 @@ -#utilities for punk apps to call - -package provide punkapp [namespace eval punkapp { - variable version - set version 0.1 -}] - -namespace eval punkapp { - variable result - variable waiting "no" - proc hide_dot_window {} { - #alternative to wm withdraw . - #see https://wiki.tcl-lang.org/page/wm+withdraw - wm geometry . 1x1+0+0 - wm overrideredirect . 1 - wm transient . - } - proc is_toplevel {w} { - if {![llength [info commands winfo]]} { - return 0 - } - expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} - } - proc get_toplevels {{w .}} { - if {![llength [info commands winfo]]} { - return [list] - } - set list {} - if {[is_toplevel $w]} { - lappend list $w - } - foreach w [winfo children $w] { - lappend list {*}[get_toplevels $w] - } - return $list - } - - proc make_toplevel_next {prefix} { - set top [get_toplevel_next $prefix] - return [toplevel $top] - } - #possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime - #todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? - #can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix - proc get_toplevel_next {prefix} { - set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" - - - - } - proc exit {{toplevel ""}} { - variable waiting - variable result - variable default_result - set toplevels [get_toplevels] - if {[string length $toplevel]} { - set wposn [lsearch $toplevels $toplevel] - if {$wposn > 0} { - destroy $toplevel - } - } else { - #review - if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { - puts stderr "punkapp::exit called without toplevel - showing console" - show_console - return 0 - } else { - puts stderr "punkapp::exit called without toplevel - exiting" - if {$waiting ne "no"} { - if {[info exists result(shell)]} { - set temp [set result(shell)] - unset result(shell) - set waiting $temp - } else { - set waiting "" - } - } else { - ::exit - } - } - } - - set controllable [get_user_controllable_toplevels] - if {![llength $controllable]} { - if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { - show_console - } else { - if {$waiting ne "no"} { - if {[info exists result(shell)]} { - set temp [set result(shell)] - unset result(shell) - set waiting $temp - } elseif {[info exists result($toplevel)]} { - set temp [set result($toplevel)] - unset result($toplevel) - set waiting $temp - } elseif {[info exists default_result]} { - set temp $default_result - unset default_result - set waiting $temp - } else { - set waiting "" - } - } else { - ::exit - } - } - } - } - proc close_window {toplevel} { - wm withdraw $toplevel - if {![llength [get_user_controllable_toplevels]]} { - punkapp::exit $toplevel - } - destroy $toplevel - } - proc wait {args} { - variable waiting - variable default_result - if {[dict exists $args -defaultresult]} { - set default_result [dict get $args -defaultresult] - } - foreach t [punkapp::get_toplevels] { - if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { - wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] - } - } - if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { - puts stderr "repl eventloop seems to be running - punkapp::wait not required" - } else { - if {$waiting eq "no"} { - set waiting "waiting" - vwait ::punkapp::waiting - return $::punkapp::waiting - } - } - } - - #A window can be 'visible' according to this - but underneath other windows etc - #REVIEW - change name? - proc get_visible_toplevels {{w .}} { - if {![llength [info commands winfo]]} { - return [list] - } - set list [get_toplevels $w] - set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] - set mapped [concat {*}$mapped] ;#ignore {} - set visible [list] - foreach m $mapped { - if {[wm overrideredirect $m] == 0 } { - lappend visible $m - } else { - if {[winfo height $m] >1 && [winfo width $m] > 1} { - #technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 - #as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible - lappend visible $m - } - } - } - return $visible - } - proc get_user_controllable_toplevels {{w .}} { - set visible [get_visible_toplevels $w] - set controllable [list] - foreach v $visible { - if {[wm overrideredirect $v] == 0} { - lappend controllable $v - } - } - #only return visible windows with overrideredirect == 0 because there exists some user control. - #todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily - return $controllable - } - proc hide_console {args} { - set opts [dict create -force 0] - if {([llength $args] % 2) != 0} { - error "hide_console expects pairs of arguments. e.g -force 1" - } - #set known_opts [dict keys $defaults] - foreach {k v} $args { - switch -- $k { - -force { - dict set opts $k $v - } - default { - error "Unrecognised options '$k' known options: [dict keys $opts]" - } - } - } - set force [dict get $opts -force] - - if {!$force} { - if {![llength [get_user_controllable_toplevels]]} { - puts stderr "Cannot hide console while no user-controllable windows available" - return 0 - } - } - if {$::tcl_platform(platform) eq "windows"} { - #hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. - #It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. - #an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. - #(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) - package require twapi - set h [twapi::get_console_window] - set pid [twapi::get_window_process $h] - set pinfo [twapi::get_process_info $pid -name] - set pname [dict get $pinfo -name] - set wstyle [twapi::get_window_style $h] - #tclkitsh/tclsh? - if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { - twapi::hide_window $h - return 1 - } else { - puts stderr "punkapp::hide_console unable to hide this type of console window" - return 0 - } - } else { - #todo - puts stderr "punkapp::hide_console unimplemented on this platform (todo)" - return 0 - } - } - - proc show_console {} { - if {$::tcl_platform(platform) eq "windows"} { - package require twapi - if {![catch {set h [twapi::get_console_window]} errM]} { - twapi::show_window $h -activate -normal - } else { - #no console - assume launched from something like wish? - catch {console show} - } - } else { - #todo - puts stderr "punkapp::show_console unimplemented on this platform" - } - } - -} +#utilities for punk apps to call + +package provide punkapp [namespace eval punkapp { + variable version + set version 0.1 +}] + +namespace eval punkapp { + variable result + variable waiting "no" + proc hide_dot_window {} { + #alternative to wm withdraw . + #see https://wiki.tcl-lang.org/page/wm+withdraw + wm geometry . 1x1+0+0 + wm overrideredirect . 1 + wm transient . + } + proc is_toplevel {w} { + if {![llength [info commands winfo]]} { + return 0 + } + expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} + } + proc get_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list {} + if {[is_toplevel $w]} { + lappend list $w + } + foreach w [winfo children $w] { + lappend list {*}[get_toplevels $w] + } + return $list + } + + proc make_toplevel_next {prefix} { + set top [get_toplevel_next $prefix] + return [toplevel $top] + } + #possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime + #todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? + #can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix + proc get_toplevel_next {prefix} { + set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" + + + + } + proc exit {{toplevel ""}} { + variable waiting + variable result + variable default_result + set toplevels [get_toplevels] + if {[string length $toplevel]} { + set wposn [lsearch $toplevels $toplevel] + if {$wposn > 0} { + destroy $toplevel + } + } else { + #review + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "punkapp::exit called without toplevel - showing console" + show_console + return 0 + } else { + puts stderr "punkapp::exit called without toplevel - exiting" + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + + set controllable [get_user_controllable_toplevels] + if {![llength $controllable]} { + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + show_console + } else { + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } elseif {[info exists result($toplevel)]} { + set temp [set result($toplevel)] + unset result($toplevel) + set waiting $temp + } elseif {[info exists default_result]} { + set temp $default_result + unset default_result + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + } + proc close_window {toplevel} { + wm withdraw $toplevel + if {![llength [get_user_controllable_toplevels]]} { + punkapp::exit $toplevel + } + destroy $toplevel + } + proc wait {args} { + variable waiting + variable default_result + if {[dict exists $args -defaultresult]} { + set default_result [dict get $args -defaultresult] + } + foreach t [punkapp::get_toplevels] { + if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { + wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] + } + } + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "repl eventloop seems to be running - punkapp::wait not required" + } else { + if {$waiting eq "no"} { + set waiting "waiting" + vwait ::punkapp::waiting + return $::punkapp::waiting + } + } + } + + #A window can be 'visible' according to this - but underneath other windows etc + #REVIEW - change name? + proc get_visible_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list [get_toplevels $w] + set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] + set mapped [concat {*}$mapped] ;#ignore {} + set visible [list] + foreach m $mapped { + if {[wm overrideredirect $m] == 0 } { + lappend visible $m + } else { + if {[winfo height $m] >1 && [winfo width $m] > 1} { + #technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 + #as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible + lappend visible $m + } + } + } + return $visible + } + proc get_user_controllable_toplevels {{w .}} { + set visible [get_visible_toplevels $w] + set controllable [list] + foreach v $visible { + if {[wm overrideredirect $v] == 0} { + lappend controllable $v + } + } + #only return visible windows with overrideredirect == 0 because there exists some user control. + #todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily + return $controllable + } + proc hide_console {args} { + set opts [dict create -force 0] + if {([llength $args] % 2) != 0} { + error "hide_console expects pairs of arguments. e.g -force 1" + } + #set known_opts [dict keys $defaults] + foreach {k v} $args { + switch -- $k { + -force { + dict set opts $k $v + } + default { + error "Unrecognised options '$k' known options: [dict keys $opts]" + } + } + } + set force [dict get $opts -force] + + if {!$force} { + if {![llength [get_user_controllable_toplevels]]} { + puts stderr "Cannot hide console while no user-controllable windows available" + return 0 + } + } + if {$::tcl_platform(platform) eq "windows"} { + #hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. + #It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. + #an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. + #(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) + package require twapi + set h [twapi::get_console_window] + set pid [twapi::get_window_process $h] + set pinfo [twapi::get_process_info $pid -name] + set pname [dict get $pinfo -name] + set wstyle [twapi::get_window_style $h] + #tclkitsh/tclsh? + if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { + twapi::hide_window $h + return 1 + } else { + puts stderr "punkapp::hide_console unable to hide this type of console window" + return 0 + } + } else { + #todo + puts stderr "punkapp::hide_console unimplemented on this platform (todo)" + return 0 + } + } + + proc show_console {} { + if {$::tcl_platform(platform) eq "windows"} { + package require twapi + if {![catch {set h [twapi::get_console_window]} errM]} { + twapi::show_window $h -activate -normal + } else { + #no console - assume launched from something like wish? + catch {console show} + } + } else { + #todo + puts stderr "punkapp::show_console unimplemented on this platform" + } + } + +} diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm index fbf9a4e4..a4113c45 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm @@ -243,12 +243,14 @@ namespace eval punkcheck { } method get_targets_exist {} { set punkcheck_folder [file dirname [$o_installer get_checkfile]] - set existing [list] - foreach t $o_targets { - if {[file exists [file join $punkcheck_folder $t]]} { - lappend existing $t - } - } + set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets] + + #set existing [list] + #foreach t $o_targets { + # if {[file exists [file join $punkcheck_folder $t]]} { + # lappend existing $t + # } + #} return $existing } method end {} { @@ -880,19 +882,46 @@ namespace eval punkcheck { #allow nonexistant as a source set fpath [file join $punkcheck_folder $source_relpath] - if {![file exists $fpath]} { + #windows: file exist + file type = 2ms vs 500ms for 2x glob + set floc [file dirname $fpath] + set fname [file tail $fpath] + set file_set [glob -nocomplain -dir $floc -type f -tails $fname] + set dir_set [glob -nocomplain -dir $floc -type d -tails $fname] + set link_set [glob -nocomplain -dir $floc -type l -tails $fname] + if {[llength $file_set] == 0 && [llength $dir_set] == 0 && [llength $link_set] == 0} { + #could also theoretically exist as less common types, b,c,p,s (block,char,pipe,socket) + #- we don't expect them here - REVIEW - ever possible? + #- installing/examining such things an unlikely usecase and would require special handling anyway. set ftype "missing" set fsize "" } else { - set ftype [file type $fpath] - if {$ftype eq "directory"} { + if {[llength $dir_set]} { + set ftype "directory" set fsize "NA" + } elseif {[llength $link_set]} { + set ftype "link" + set fsize 0 } else { + set ftype "file" #todo - optionally use mtime instead of cksum (for files only)? #mtime is not reliable across platforms and filesystems though.. see article linked at top. set fsize [file size $fpath] } } + + #if {![file exists $fpath]} { + # set ftype "missing" + # set fsize "" + #} else { + # set ftype [file type $fpath] + # if {$ftype eq "directory"} { + # set fsize "NA" + # } else { + # #todo - optionally use mtime instead of cksum (for files only)? + # #mtime is not reliable across platforms and filesystems though.. see article linked at top. + # set fsize [file size $fpath] + # } + #} #get_relativecksum_from_base and fill_relativecksums_from_base_and_relativepathdict will set cksum to if fpath doesn't exist if {$use_cache} { set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $punkcheck_folder [dict create $source_relpath $use_cache_record]] @@ -1648,6 +1677,10 @@ namespace eval punkcheck { set is_skip 0 if {$overwrite_what eq "all-targets"} { file mkdir $current_target_dir + #-------------------------------------------- + #sometimes we get the error: 'error copying "file1" to "file2": invalid argument' + #-------------------------------------------- + puts stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" file copy -force $current_source_dir/$m $current_target_dir lappend files_copied $current_source_dir/$m } else { @@ -1859,22 +1892,75 @@ namespace eval punkcheck { return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged antiglob_paths_matched $antiglob_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] } - proc summarize_install_resultdict {resultdict} { + + + lappend PUNKARGS [list { + @id -id ::punkcheck::summarize_install_resultdict + @cmd -name punkcheck::summarize_install_resultdict -help\ + "Emits a string summarizing a punkcheck resultdict, showing + how many items were copied, and the source, target locations" + @opts + -title -type string -default "" + -forcecolour -type boolean -default 0 -help\ + "When true, passes the forcecolour tag to punk::ansi functions. + This enables ANSI sgr colours even when colour + is off. (ignoring env(NO_COLOR)) + To disable colour - ensure the NO_COLOR env var is set, + or use: + namespace eval ::punk::console {variable colour_disabled 1}" + @values -min 1 -max 1 + resultdict -type dict + }] + proc summarize_install_resultdict {args} { + set argd [punk::args::parse $args withid ::punkcheck::summarize_install_resultdict] + lassign [dict values $argd] leaders opts values received + set title [dict get $opts -title] + set forcecolour [dict get $opts -forcecolour] + set resultdict [dict get $values resultdict] + + set has_ansi [expr {![catch {package require punk::ansi}]}] + if {$has_ansi} { + if {$forcecolour} { + set fc "forcecolour" + } else { + set fc "" + } + set R [punk::ansi::a] ;#reset + set LINE_COLOUR [punk::ansi::a+ {*}$forcecolour bold cyan] + set LOW_COLOUR [punk::ansi::a+ {*}$forcecolour bold green] + set HIGH_COLOUR [punk::ansi::a+ {*}$forcecolour bold yellow] + } else { + set R "" + set LINE_COLOUR "" + set LOW_COLOUR "" + set HIGH_COLOUR "" + } + set msg "" if {[dict size $resultdict]} { set copied [dict get $resultdict files_copied] - append msg "--------------------------" \n - append msg "[dict keys $resultdict]" \n + if {[llength $copied] == 0} { + set HIGHLIGHT $LOW_COLOUR + } else { + set HIGHLIGHT $HIGH_COLOUR + } + set ruler $LINE_COLOUR[string repeat - 78]$R + if {$title ne ""} { + append msg $ruler \n + append msg $title \n + } + append msg $ruler \n + #append msg "[dict keys $resultdict]" \n set tgtdir [dict get $resultdict tgtdir] set checkfolder [dict get $resultdict punkcheck_folder] - append msg "Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]" \n + append msg "${HIGHLIGHT}Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]$R" \n foreach f $copied { append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n append msg " TO $tgtdir" \n } append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n - append msg "--------------------------" \n + append msg $ruler \n } return $msg } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm index 8405fae74a50ec468daaff5adfc86c3c68353219..d365bab1e00edd610a3a4ae19fa00fb3d3e10a44 100644 GIT binary patch delta 8944 zcma)hbzD?i_xCV#cS;Nr(v6gKmvnawUBZBXz|bj(9J;$Z6%=U@R3xQa5D*YS5G39a zz0cM6{_~sp%$!wwt+n@=*=z0Z8QcbU0N_MkI7A!zz}wLi>IH#1!W^KU5NmHo7nq|P z#NW}w&Wi)$?g{a+^AZ(Bun?F##MRx~4F-AW;OGMVY2g92<-&se@nVp6fk8dptYD5l zP!~Ulx7*KgUhWW>gB1({^@Vv_*}$N-5C&IwTMu_zP7i)78)qwfD5nq9)63D_4Pxi+ zVv9(^(F=k|!OO}O`j5oQ3&I6+h1ekiKjop77e!?9(}Sp}i=(xusH>GT)B+L8;+GV{ z>27D|1%<)6qKxRrFl~p?G%>5iu~(NG3`cH5oK2hYCAoiwbI7o;Zp7vqavm1 z{;Z4?S7$OGxg{}F-l|BcNtfgqyHs_0=xSo>r3@)*LGOm zA2O7xSIP(myFIPPCmr|%Si<{zp<1)4Eykdr*}isD4u6JX6}3 zP{9~3Ke`qp2QhW}W_~fLNc&}dU)+Eeu7yfir%R0tJz2$jve9s2Sn->c@&|jicHfJ< zJfyBSN({4QyvdsyXy%RXJ)jhQVo>%VJT9!8<0{6TY;>(0&$~uBg(KDDgDFnb(L%9K zdl-YjJ$mW>Mz#DSxVmTp)$IFsI3uJK4W+ze)x!Knj@b6FN3u?^J6oD#c%|>SrzPYp zP<5Q#yfW11{ap-rrqoDv>C{p*BW84-jGUQn#INb_o}~0z`Uz=s5zogr+kbwiyb!1O zI9+39>mk13Y6&Z86l$i8rqau<{U&A|YbKHyFnc~H>yY)l4qTW2i??f_|5xG0fWBMG z9%fKFeqIqdBz%t3>6IwDo*#qFlqaI$BEf(hW+@?9Z{y4Rxn36&ilWF@REy>oW0NGOlg+i1neF&2^SG>`39)Ke)Z@6jKlBWAp%PT*~kh4q66WT?5I9uCVwbO#MUki|$t`%!P(YZT_{;?u$ zm_lOc#{eAvW5^-=3lh~J1%sTDJpOzLnuH+q`D?j^;30WyGOFIwC#x*UWR_{*cU|HU ztsS7-pE399}w>&9TF!or(suQP_+ww{mxpUuDbqc z{(Y0G!Dr>KAxriax3RqMYD!GbMCOQ2n^zCuS-gZ?5Si>fo2`#}QYH(*P4%Z9XFFvM zfUneE!kb@S?K;6`A1~~O<58ts>h{*P2{DvQz;E|WUix*K;oVwh-qYVh_uXCKdh5Mt z&LF?qfgisATmoLAP@)xB;OEZ`~fC<6omu=jU$6V z+&{M|xGmI&`+>JRVv}};`fxP*@G`^IxHwjuwQN>KZkmW@1)j=zZ~{#}{bl z>TVN9zm=NZo-@Dy>?O_|6{{*oQeNV5!qN~!t{wTF;o?`H{1P)1Y2$_f*Q>4%!BgIF z%oc|Z`(^z_2KVC-@A^=q@^8moMp)y=$O~caDthoH`{zbxjK*!Ai&*f(PaV=M2NeY% z*1_wQBo6h4_SH*HWjfy~wdK0@L0TQg2npXa)rD3gCtUf{&gN;9!m|-rqc2z_S5Zqi z2v1UK_^|4XHYJpBNdEY4hB$akbhJn8bla8;te#@LD1Gv6uXskMSypj#@p(dfP%@@A z$xL7>^A)b<|85~?e4w$9=4rnRqS7?t021_K@Dc-6_w~C35(clVD~CK9%ZV7vWTM2m z=6b>M9pWSjRPTvCmKP{-Dnp4;&JS|vE7G8CtUIzCUUr>lo2;8_*g|BV8JgbnxjOlQ zs;H3kIG=?W_r&YxaMaY!qr(SmW6n)OH(Apn*j`6cx|crR4)>0{h#=K}k;FwY?ZJ`( zg-gnjv#`r;RU7MWozEg+AT856kEoAe?Pn`psZSD#oA0LtqG&yzkXc8DD_nb{s$ce~ zLO6?M65kztdWvBoPk39R0a?-0qQls$K0-?JZY(34AN(Q%bBIs$1l^r*#a_ESOW#qI zZAo}ULO9;O)VY;B`pfv&p08iY)_hr6b>R~%lmy#0&v0X?V2@7Q_ISJoQcazs)k9d@ zpf&t6TGYW$fDyBtO5 z?UO3WOafDf=tb#r@nUVO{2EKcV3I?6k*zc4jEj=gDX@eoaGzG>7#n@`*y1xuBstu- zf7KwBR7K^D1f$m>ueuA6^s38^$Fteq^j;hiL)84mjJi>ljmDUxg#;7VGjHo`RezN| z=eW74^k6?uy{NsXrQ3?%EECTOg3#qPN--{WQJV#gQh z7}o2z7Fs&=hp&%!3PemBQ5!4qJ@u8{Bn#e-3Q*{P-I79_S;`xpeRS|=W?7(jj}c3w zw*E$P+T_92d1MqVwv9H+_87#z+A~v2?Yg*snB3aE?Gt-gNJsa2x7Lzu;%qY%?v1m= z&m*e_lX`lrTRwW0Ef@$sSXNwm*KM?vrgTw#TE!Y3q{S08F_WpHkD+%@>xlr#P}lyr zavcOW)b~iS-Emy~40@!~dY0`P6u0H=y+;fWIJHkT33%vuB3k;9VuD-K&g?Y4dHs6b zzqzE^>Ph^fbGtb0i_3QEdjZl)@KZs&9v*aDJR7}rXPjk1e$T)lNp{Cr%mZVkiw;}* z2kY(ppRfk2tvESF89}$uU!8HgrqH#FX+j72SLE4ocWUq+nmc@o2$1W(EHS3N4f7SX zaMXWhR(1Z~QRP17#J9pGz4LWtOAfZr9{ee`4GMjo0(dU;m^#FqHU$+I67a*ZWBWA> zk-jN@#-{N~zc1W)8%cT1bL*(KcGh}47Z>RF)mMwg*Q3C> z+n(0WcLSy9#R}iSs$pML3NFqG%%$>lp2J}>ehwT-14$HPx|k`jzR-DGal#d-M`L$&q-*b^I5)f=S@lVy?o}A;NFrf&bXjUCs$apL ziqUrC#E2kX$sGRpG}F_Nk6!$PQY}d!n@W^TmtnSC|dw zHD0ekqWgd{)pU>tb>g-KA@R4PM}DtS+X904pIo8+yCEGAnX?(y^x6wbB1()W;-dya z1L)O+fhSq0fH*q=+VwRUQB0cD*-`HjQt$^FBTPUD$<539rcd^0Km*>`5#43r;$pY8 zf?0XNJiTpT-k#9Extr3&WoPB>>*DC<{JTaWg8*SyYJiuM4*2QjOC1*aZw(ORYLCSC zzW`tAPzfz;JYDR#VD7Fi|JZQ5858Rj2K|+kK4Jn|O?1G4FDlUGhR69cEl_LqResNO-VIS3 z0#jdE=X1Qr&XjMH8tajwjdgpEw#Xx^Pzf zg{9(#hZ626J^r9)0!fOBOwT&zF)@;pk~C9Wa?^FRH70t+P;e)zLIHOY;dH!p0Dqnu z-s=3L(n#e>sUKDWa8S4g# zE2f3ylRc4ahifDhtCX|r!<*pvff&uXzPoO1uY}0*Vl0cvi=v`Ap;4{ct4k$}z@9>R}0651e7;Si&xQ7^htxeQ-ur zG*YN`Yu%hkUFCAiCO_<<2j>K>kLcc4F7yDMbL8d5ERmxC>JR%*d`w2wEjKrD&nsJ_ zU;C;(2-sIxex^_((k7mrlcbR%{G_&c=bJ`!`Kg*P{MhcsCjwJ40qd~ z4S=eM+>S?5y}3puvjZ=POUcXfB(lx2Wfn%A$nzw6NE+o!mU^_y$(MD-YS9DrAL-af zL3=oJ9Hytwtm4Su(?|K27z{o&N>(YF3m4kxJ2PFhCArBxgtQ{v9M7 zrP_F9xRKUnSl9)4TF&Xs7C9syBaa*CqQC_7fl%xLOQmG3Bo^9;c2#1Il84Dfnlf%4 zwVXxaDp&A$naq6r$2`NVx=AOV9OaEW{M$ti>q(In)_JUVRaz37XpzLmtQ4~(;eDc1NAfWyR`4tdYNS&0 z8Jo9$_E_~ZH@g)=s0i8=Sl#(hM2VXgLQ&-@>AVV$^I@8NSBqnK=t-|2z7{E5_ zuh9gTjim~47kHSgtkx6=J9eG+ht`z~uw>`p(?tyuQ7a1bMJjncOXf$}6x3r;nZdKM zbKU(4k0OSHzborSqw-Ro zjXu!IzoR@LhxaXGRB3dG=CT>XC&|EB>jlqnng@%q>=;!xvrkfrA?dB>$hX5oi5Q$j zvdzuR%nNdeh)qMxRHl1`RK6`sJy4OYiC)Ki3{OuUkj_rmSoayEX7sFJ>!;R*`x3^315xmF5mw%=pC4crQ|`N?&B<$tQ_X_N;9R zV*0mo(aEy8NaW$l9S=eu;11g1Gif#3YI`+0Y*tf0+vbWUy1(1_yu~(=k5Wr;vM6Sj zGXV}8vh8p(;hDmFvvDzHtL7C^G3v&qVL?5Q9ean_xXBHha=Tanz9v zzPA}7t*f+JWfTBU9}Uw$5)UDGkXYj`Fw89fc*LV9vdy6P+$YbRP@`kfW$NiLzx@T@ z0Nc#C&Xe?eJe3LUon(u+mAUwOuPk!&^2}k)Lws9#f*6%f5wuS^nzxRID{WgJ>R|fA zpZ5dL3DF1M2j3ZdhnIDVoc+DCuH!I|YtX#a&$M$9G}6|h4#gy@B<&?Ypkkxj2lKTu^4sCgNefC~t#K8E+*{Qn$4S$@8?Y9s0WtmIMu}aK8 zVudVJ&khE-9WbT|KG&nLe;xT@l^OI<7QXih9cg!x9e78CJu1(kcDu5qjbYi4k-p{5 z{f&b4JpPICp+r1Xt=F?$0Tc5^LYFZY=U%;Sk?tA;Z7DxyCc!+9s3KF!KhmD1&wr{k zWe45}7}mFR2c@Iqexur<$@cH}X|uXZ9NeO-{jf5|B>8N(;;v z!w-VyQO_HT5!#h=U5uM z=;F#VTa@Xc?XFmY1*1c=WdRn+Ay2-ynNkPb@2hSHj-#AIq9vTxE@DpyQ6HJH>R&w+ zB#f^p{0KLkIH&u!VsjJ+8T1`zKldgeWY5s2PkHYFf1k^&w8rqtTcKS99 zJo@R`UAE(4aO+&?z2(^U#Bvw;Mq8&rpRo%{gN2~&&r*kv<;w`|Wb~f0m0O$%I7PU2m#0P5bSU^-lv^PI&+N$#UQGiY;8_+`RN(;nNpZ)l0i7f(!O zCP?B!mJTjIW1rj-b8*eG2ift;Ce2GvbaWrhX|zsYI-F=Q>n*_ zr9b=`hcvBzTz>zfA--Q9WbENN<$H#>ztX56knl~vhq%A+KbyIn<7;{6>;&~AS88{Xc=pt@d{ajcram2S%FpW=cuT)L0_^BJk7Z7!gO6MoN+1Oxo zt=|fCB&p*w;Crt&V@E-xu)Olw5yYllsA$$iusm*A~EAw7BWhEJ_%K*yDvdqW;q zV|zZfOL@gi-4Bz_%ICdPUwKdG?BM?3(E=Vv7EQXx=Oc*B!}o6a0GGpKTwm;jbX!qt zdrIxmrqI&~=#Q+~0yG~|*^hm}S<@zYYC-VNrAiDEFI{H2ySjVkSzBmm)p5(=oLA@^ z+7BL|vFzGLjT1^sLV-M@#;@8K@%KcaKcmWHiJ^@C6G5Vn(#@ zl)!c}!LRncMt|OIUV$KR%RsFL?3kRC5SH(d0ud5Jy;u=&IA$goh^1D>e%dj=Si(hk ze2`<5M8+!O7?Ikl_CUmI^UWf1bQJIR>Xkw(x6HG_9uOLg6xojix#`+&`6Q|V;5m3`(=3xD72}M%ChS|-_~g`G*b+zM9=>Lg z(mXTDVPd@IQ{%dykB3C({ryW3p?)zzUPjx*P@DAkuy!w|2Z3GFZ!wz=2yJVe=Ge@g zGwBC9Xe;K?sBR^7IPmnKdcA<~HIMt_;^pedPzAQ9*)VHU#+bkd8 zoI$3kV03RoBb8npMN2hap*QfDVCNn0^`#6$UDq;GoxYYPtHz+&Rt$ESDH>^L%1 zM>Z{QPpQd@pN}7p>rEQ(^OYaN{d9)5Y&&ip5T_Z#cU?4j_&f>)P|dsFnTFJRwYkTA zGeOn9!?!-1t=VG&+VRmw@3m+y7!Ru2C6!v#v`S)hKXsgw$7q>YBo(l`RUMWtZ()Q= z?(e5Xr=47MKyuK_xLs2$%u#T^nd{I3_X)tC zq5g)PK_J1uTuh-MT<`&snS{WLOj>X|~IKM?g;5WFxNn8Lgn;&e8 z576g|0)g4WU>kzpBpyJ(g9*%*;Q%B#v|x9_8}UjG4&a}|2F4-!%}Rn>f0BVyjXFWGOF0!S>z0fO^s!R6!tVSyB|lFtn$ zq(qP&;1>EDBd$VR;B^5TxZ?J2Rtj9oa6?uU@`EKAZ^%ViLV%@+4QzkshK(=$$%XM zi^21oRR$ORA}2~kz*M{lsVMNOj1Vv?V*{uD!^(ka_z)Utpi3JKP%CExQ}O?1@o#24 zSxyUP6}S<3=%N8)6>Q+)e^`9LtrQ0!s6hb+E2zK$f(R=`fUS}Z9B>ywYW`08W)JEW&?+b{${1XaIxPc zI^a>m17^MV2a5)Ls^JIE{uHqQ^|j=HX)O-qKN#Yl$$+k<0j&n6pK#(0ZuftN6M?)s zHgL4e&EPL}%mjRYdA%e1TY-A_Ukvfj|Hywa#6QQs`!yT^CbIvZz{Fpk0f~ncf338N z93l%9$bSIEKSP0D$ls)jz!ok4>^J|f*y5j)`VY4FS0GUZ;IL5=@}J|(Uq%@B5k_2y zlMNxqpPv8IBmXssO7murRx<_UKmE~PhK}06STYNlrYb7hPq`4{4WR^qp6UPO{vQpO BtlaoA1`tXGkY^BO5b= zpH_|r|9%4wc#VitYXB+<4eDB31Vexb+{PhFz(PZEH+SLX{ko6D%7w(uzLo{61RPbh zmR&0oLQ_2r0t7@73j{;}=%`BqoN^=q(%{hoTpOB|3h9(%R7F02dE}d_Iw!0M!?}tP z^u-Oe?zRg|N+YSDu17+Oh8V!5kuFJTjoG1C#v3ZM!Ze}5g^209!<(@zU5rqCOWXfd z!b3m=9hfv!m`XdNSAwGzrAUg|l}oQ*9tk z8uNB#GY-;Wnsl)b^mkLwo&cFb+Jswq0B;PQ*5*Xi$Ug4hV%F(DbLKNW2ldnEh`+D1 zGR21Z5_uann^E*I82hFw<{Ojn7l**O%n@aQ<4qe9Z`b&(@=wG`B^b6tZ zOc`p{mAn@&ti!#13gdQR-`+0#W!gA`BmD0~gqiLGRwmPbY{Owj1`Op@&<^>m0)FUn zI0oBg{k-9B@WJ3pP-;y2CFkTE21clPR)I?FE43z6EdO`bXbLn_94?p&AyEV|Y=OvZ zwI`KhZT{%t<>Y4eQYmKR)7cHwEQ8;=C?j%GBZUh)_rUdb+nuB3>1wclQz`jvoahH; zrr5L9-Sy1@mu8l`nx%`)?Dnx^2EgK12KqzW=1`k@vX7M7b^YwY?|G}skEl-SF{!&p zG+OyxGBq|dirGVIMe5MqB?2)j3L`1YE(UhoX$)&6$-X`X71hoDo`^Mb3DZafgYfK) zq2v0YaDny$neVb5Grp#3PJgRz`wOFgd+4siQ6KnH$7JhrW2;=_u*>6rs|E16V>N8Q zS@?Yj7;Tu(2Rb45b3nip%?{DPW%!@5Xu0>3Z2z2n%VkY4Z%Qa0nkVn$PDxjp1Qu3G zc8J`AR%0TS>Yni_bB!8C&iflowqL(MjeU}`JX$+CM$3XKpsP@?N3A5k=;)NebNx0= zFl4Y&FB>dNovpo@lP(I#-UsL%zTS}R0FH3eq0$Vcr1~dUv!MjIiqfQ6$;C}^(t?Yx z)`8rxlsrq6J-BnoJ3N*?N)YKkb#_si&xFfLOL)F#(gQ?TvXn(VuNKqD ztTvqZ9}Zt*$xo>NY>K$=ymF5HiatE3Wv+GU;|lNAD3vD74A+(1`lh~azm1+i1%xjP z##^vCyH-`nNG{fB%qvK#Tmqhfw@-G+?VZ}@`jq}f6ma{~t{F|(^HbzWqGjc}HV+wF zDO3cHgD~uIDb@w+p>;(?#8lP8erhyAgSd0(HB?tg8r-Z%%dZE zrD7!dYN1&#`?RHi=>I!06y?WnpD+Wc&H~bqy5kTw~p4l?4UhPV(6szh4$7@{&3o ziqxZ?>|Pxb9Uqdbc_{v)L04KK1^4rkPg-HO$*j=i7Y_ZNnBe-mt3fCFg}XD>W({V* zK&z-F1iozKfIHv1!hi}#U92BIl@W(CzKD`L-?XnzVe`xaEyONh`Y7muOAfvv(e#~s zaEXjqv}!SNkWOCh;4fKVvMx(-od|8d!+xeCd?@U~auYjt+6*mlhq|^W?N#qkfF~Tc zxd2TVy_SHdIw}wY>)SJ+vsmKX5y~T&Eajop&@su_e7%{4#3O>>r9L#UXlHfHVh@nn z*n}s_bNUzG+av|h?j^OT<-ktyC`}+Sx}np7os-bSD_%{P)bqzkomsL#{I~0NcCO-; zOBJnFHhHkJMTr4Du_$9%1R}w2>qKp|xSJk4Qgvt~`$Np{98< zgR_Xb6s40ijtnu^SYxzNkb3p> zVr+8~%w3K;aminUX=Vc_WDUUsojmpW77LN%42M^Ms1xF<)7=;X<0P8^+1hj=h$Y_H z$06Z$K~yE#+7uSj_5P9*q~FZGL@en}@9^MTkVl=PW|1q5#A%w zc!iZqu0>Ph2{vmmYB;We2-sqUGP`g{kv5u>UR|@UP;L=62Kd`)cxy@E{=Hfbsn7 zz$+3+K$g0!!!9R^plqix-Kb+tDH=tIXs7_wN-vm1s{n@nw_M5*WwCJWgb^y3w@p6w zLZSwAjtW9eIG$Js^A23+dkJmm3w`dR;J@;X&?P#MZUu$G#ep^jp_R_X$Cq#EM|6oP zgg9x#m2;TKFsJiTb%D-*XmZ4l=h%k>Fe`#&0NmFmZ9VNOh=1k_nmA%@g=wFBH@U66 zm1W##hA+#Hr*``lTD_INRV70i?2*4XSX*XLYk^9WVz3QoQ^!I)vBga91TM)!Jla`C zL1@t3?d~**kzOha!a;f|jQVa<#vH5{pVvFpU4FZL6C)6Sn+?knT`$p3R#4}PqlnyB z0W?-z3@Mow!KWF;(?k@AAv_&Jk0rS!aX_Kz7$@k>rxG*-5nLs)bTu4XBl@<|B)E)c zRnMHpQxijd7>nR}=NuZfg51f2nZ8wGr>gQP4IHB7U}fmV!!5(zZ(byAh%8tkRBM3U zX5~3aZ902rO?t1DFfc9C9567(QPd{gC`DgZl&u7OKIU{|7jU5ZPt^VG1G1V2cKR1GM}CRIN%1V z-rMLL^wcl8kmfSayn_*h<(DE#Zt{rj8-C-5@1L%v zF)4mtkX00-S_dvcxJn$klW3fTPs6%pe_4YzKURt`U<4hb^&Nm7X#iYiCn*ay&Wt>o zfGiKl00CuLcFCSjnY*D%>$aD|k`vuyu0W)*tf3vdka*1#5w-OJ|Cu4SN`}LLB^FK_ zm}|Iq_}{Jkl)kJTz1)>p*tON-db)J9yl1=ELd-}YS|~T~ub9}1^inq4Qm-kaechYX zSO%Xk`p1IyyS+Eg+7!~1S-Sd)y8w{?4XZfoK&+TASP^`6dcps|>OY;n=)b77>i60E zBYE3YnNmt27|C0=E)+7t-J7P(T39x*B804-B1s<%!fUF zAKRW`NuYL$)ef&2{I@o!8+ntzWKV^9`=3AdEzp1g)8HH3fCJo=qH?KF+^XW{<6yUl zw=_VKdRrU=&VqAks+kbefovOt#N`}s;^E7%77AF$CH|=Vpv*;^)Q27inx4L0(t2R& zx>eb=zYwWkaY%#L0cISAF)483ek%dRfcYSjXT`^qFXpM^KKj5=)<2s;Pa5M+@EILF z?$C7`Ss(j$*>k-vYbF_@%{d#;^-5ig-vGcYeP6qtxj8{fF#V}t-k>(KoQ`WR7ST3k z8v;Oz1YWpx-(*R_$73x{n~D{xs-Lh*|Yg5Zq)gZXrtFU3@9pSGI2pI=RAh|^*?1jk4o)N-&tGnC4J&vmv4jor0Wi(YW%FHrMeMcA=7tjvhPuXHoYz7nY25xYFpwc263ks>SXN)tr(0x$GCxj6uCH;C5;sRQx1vf)0XEJmAc*a-5S$)pbfycb;=HH z!)3^y=;qk)(B6iSMIf~2tjZQS?CmDP`*?XAg@Zt-1Or_@a@Zph0#p?K9Q51p@;a(nxH;Q?ZtdU|i`(GSY1009mSV7>%?!I9S=SfCVoI3LSuP(}pHG>ed_HmMcoCr8 z8S2&L*`Ofae21kSNJ%tj76TX;H@sz1m6MWA6 zLd=X!bohIC0%f4`gp}IFixFp}|B5to6)>dxXorB;zhR~I-34B+djwbe9eW4EfAz03 zl5{n?H47tqII7LhOauR_Lw=VAM}o4LP^nBcz0Al3ZpKsdMVk>($X!7C)GF`mag7xN zfvw}rk3#2es)Pw{7ixt2ED_)cq@=*3*hyeGpu=i-4?M1YwLO ztwfwB_J&2FZrGlSKqVz5fIa-z2OjkZC<%N(M{noMv6cM#_7w@9PP_GGy zD7;XmbLj4R<4%B%;JPpNEdT^)L`eWl;O7CxIzs|mDN$;tDIqygk-o%NrrJ8~(ihJ- z5dW`psb+-*o~UF0zuZfa#-`#PCyFl;+Gj6^X}up4iRW0aK(=;SQh9Qyy0^}re48!O z;KVW#wCHQ6$AHj|X$o9nr6Ky+B>NZI9#U)hzR*TkJH>9N{S2b+2G&rq1*HwUsEt_j zx8?lu9S4ZG(+n{#%VaY@g=hZ81{fbF`J*$Gqh;3*Z`55KBi76C>iW|;1Xz!=Rzq~H zE5rjY+7+v3(|oKoo`pRO2vg4=y^XHnL($>Vw(;3kl*(NfT@<{9f(h0gDs&NOp%}m} zp+35^UnG-=aAUEIN0AkfnqO6ycF}KHVoJX1>+530>XKGMd(OySJa3TT0wCSOCc2x> zC;xHn>#2e&vlRtuMD4{3IF5}x=FM9+V2S$|Q_S4PJG;WFNuc{~-QQ8j&e|=~+re&O zYs^zl2(hl$M0d?k9!=dGK;8K8>i@1(omn11Xv||FN;G?_A2fK&<1q$ovdjI&Ed?pt z3+)#Y0DYUnD|bifI}s^G1SG2DP3p6Z0ha6V;E2(E$?Lwgmank%Ivun~A<2$vgQjQ% zX{qYhuv=suJDf41`vw?Zx0hQ}QXYUrRF6P&-lf8Gv&C5>9e>+1!b8tzL>sAYsS>Kt zZdOaRCdgolEZ4gHl|6|Pg|`%+3AC1>rliJ9l>alhmSX$F{>NCD36KM%c)sgwd|eWsM8)Y+u8kU;=#*F-UCt z93wRI%oYm3b`S$2JB6+@wk?2~yQ$)qZ`OzH-Unw@2wD)tO)nwtT)!|OW z-z4T^EFpH#bK$d01IUx-(AQaw`%4L!CcaLaJFo6|$~Nyz=~x;36nB_i;4yy2?Fi!S zOv?KGOxr2vW{@w)5rt2TcQN^NdR<+@7(BW5{Yt?e*|Pgmdwy*UUmnvLiL`);`lv6u z0>t5dMPk-D0P*&X$Lz&FXE&n>@6TMxfbRNF74Zt=ualvnE<9@~gP>aB*Ek57Fj$hD`0O`xOSKZ4GJ|ej#&Um}CoW9GA zM)JBQg(<`hH!AMmV02M(aUqXf)#c@JKI7go6f#ZCS%LPkBA*m-1)H7^kUYf4udfrH zPT^cR90852R8fm3g|R*O#8rEV%QW5xC7mMy`Q6Yl)2DVHtbErOQ7V)+!$=Znh`(rX zFy4|+0jzkRVTin4kz(K?V6%LEo@4XYDABswC=t(Cm*B-CgX5gVfde~cj8czq?Q8|6 zm=s(!cpl#kzah;${DHJU<2th8hkF1q19_=H0zGHT?z%h$xM(Zd23DK%A^n;ex|JkVjiXKv$yh06F(;Bxm4NDH zy>Xx0H}m}xvNlYsAfh|>iu-Y5(8{2MLsSr$?>)R{V?`IhuI-2T94mG2Fb(v@%i{paz2FK4 z>aQ1uO!jjJg&xp6&}owWHJg)Gp-$<KtOip&CQ3J z5gO}30;y-r=+^7*j}&O;MRh8Xi{R?}(eDc*$o>^f6VN>dCbdg>9KkTS#)=W2E|zwKOpBcJd<2m1RwqO4to$#d$y`g|_X<~mSHaGy;yDU}=(Jt-a7a0`f^9QP+pQ|2z34p3u=n%*}jQ8k;z);X*#q+njYsU04vl7=$c#7?C2k?5#e(ewW=`Mfjv-^u5gR`CAb?flct0eK=Y@^Ke6 zv6WxNLoc=?nz`yb2>|`)Gsnxvy)i+IQ0R^M&Hl{`xGhxZPqldvI0Qblqd$loj|vT~ zOYoyJMjA-~SPga2=0kot+RxYZQtd0U6f*O|*=%h@eDD(8tN`GQRcdzV4ntl@2$EMNM-9}oO8`jWZh`&<;*sOAA@+yZ|J`GdzbYqTpFUUqYlz_Vbua?`RQ{

EUB0}3qBwE*P={=4g-ApNJ1{?&SbvU=J`|9rkJz60>_Re9iWKw?7*Aj=n3*YuG7 z-Ji15D`Nin<9Wfg-q`fx2($mv<_TvC_Kwyx9=e4Y_zfDED=VI8&j3Aqz%GGVh<4kmZlCAh? zPWhtcb??NJw~}{q1J+l1x^nr*a;I1WJ|jv8F`R4>DgI=VO}-PzEk*HYa#8`YNmsXf zt6QK_O-&peP)zEC(zdr;vw~dkH+!LXqWC${BDUwjxWw^tmPUuU)rKYlkks_8*N_9$ zOyLCwSADpKpYOnvoX4pRACmWo${7&;=(Xq471^LvXu@WXJaU%1096q!lY8s7s6!J- z@A-XxW1VYUfjgXDW8b*yAz$O_IKj2SE87Aaf$7ZS8cS4DxZ-YwqhcCQFOZjgx^_JNKn<@GY-9-roQns#q9Tj0FsyBR$>BT5(Sy*x2BekI-z-Pcq=W)B1#7DW@ zn(fKqlPdw9b-GzWB`hckHL7>ywincsCZ!*rbMs0X>x(Cg#V_q; zA9M|Q`!#0);08XvfJe0;J%6*BCea=KE!|z)@gI?&c3-LHaB3pYy!}ev*8b#dPj6Yl zGwY%(T?%NV)8_7vzUA5-*EP{-&@4%sUBhyZVsA+wi2fG*KB@7DV!DAc{ge?-43Luk zbbq{#o6X;D<*6bNQX+ugMBttb8-AGZD1l#-a-IA0P0wu;0O#x<7EgLO9DkB4!b?cS zvA4SP{aB#&flm52?!!29JWug6COK+|)roXIeg$>w4e=rxEsQLJs_h0VO0?4L zmjm&`gZhciS|s#Ku*(Dn>YZ(+G{rF2HU>2Qvmj^P$Ys<*XV=nhd<~j8%Ji~Q3C)jU zS!W1hnu5g)z>Xfv@hymKd>0nZ4cSiHDC(cX_PSy84tmxY&#e-%dj8D`o}4Uw`HBU( z@>zW3kuW9>WN(>f1v`#Gf74^`D7ByARKe^mu=hzYMMPmf`C&gR)l@9cT2iLgzx(mh z1>3)d^xS5~Gbr578?D}7oV7(8pi*~Ug{dE}PV5ifQ-vx}C*3)}mjOSa|2J=v_6S8# zzs$Y~90&;SS9tmFPW=xu{sWkzFKp~eA_$E7eS+r=U0vkM#1XhH?dA($(5wj54YhP@ z=G)mxvah5mbBb(z>N^WkEMJofLw;A`Cb)_B**iL+|C+my5Zv`Fsh@WrEA&(*S>~xZ zn%w2$S*(1J4h30D5o6*oD9^WS3-pB8L7kIiZH7(e1Ke+d-MS-?@=z7tYIJp{jTxak zE2w{QC~gEKUfoXd*0q;Tdn-SwHbm(9E?IkkG~dpwOu-AH`nf~vy+$EcV;LC%H|~!T zPyxD3$?!GLG!Ifwz6cc}j`b9ZF)0|dP&rQ&6hAPTA-YeUHno#&M|^pI7oVE}t)!qt09Y!;Rs^cZ><$o$s+`VlFq4RXUN=jlR{4w0+-iZ?Q_$Nf z0sw+f@UIt=n0SAa6>MRy+vTdCt;JizfHnBz@5Vu*tpcZPihI9dvt0y7x)}S+3K3^! ziC{)SoM_QG8?+qKg`PlOd`A*$MGfz?;~3;cy{BRM*9sx58_VK({qvX)nT` zG&^T>jV)fJucnD%OX1lWsk#+yS@SwOwq&?IUQrjG7=P9t=cUK_LoAI)J}5(=0MPMM z-MWPo`y4ZSCv63v#gRl`me{=Cfy%$JTkJTV^7KUbjsgQKBLHEu_>-8irY*2lR>dPH6 za7#fb1q?!xCbi48aEC}-$O(1?Y{Ttkv1Oz(_1ti&Ida^Q;C628U)BNznZmMc?P_}C zDa0<}LbyA`*d@`4RPF?Ru@v?;adV;2vh)jP*wz!77AznYV#y!T5wmCr-Y=#iB^RM{ zs63{(!Tnalq~*%TYbDRe3to$_7tbrDHc)*e1|2EIX}QLios2vR-hIoV%9@k6nM680 zR^6L%@QD_FYK`v@jVZ}dLX>gk{tVM*`T+ljBtX_s9H5gfCD11n7y7@J8fu;N$v{#6 zQ6t>?YNCW+&UpUokoYg@0`(6Kg~khH=7D&++Kb-jkQTXgGOf)iniR$!wq}L_Q2VOq1k^k(&~O?A%C$ zV7-~J!C0liy+lOB?hIQ2dF;_7*VxhEVQ}ICY>6W;W-s;t8gWC3nOTmcW#_JTcG}zF zTsaXcY*$?Rjp$#C9v)~ZFuy#ID;#QR3|T4RB;c*#bPc2Jt?&{~8PwiSR|(L6E8Yi< zdkct-T_uO>Zy0o&s21Zd3?M?>g4Xu*&Wsr}YXpC8>DUt`bCR8meJltZRe;jHiJKHy z@Uq(FPW?uas$xuFhUy7PIhfpy|2Xg|#oNWYMKuO7$Z~Xs7|#2{`U=J;e?KTuuz01H zrue^+O_OLX$N7b9ReTT-=6@l3D-;pHFih)!k>ut zGfx^ReX2lQ@=sBGyJ@>h-EWG@X^+b>YqQaaU6-{w*nZ}OZ+z^p7QQoMl|q^v3&NH2 z1T}3Cd=k~qjMmR7)ohD~e^R%o<6yMXCQI##k9IC*N;vA_@u?w6LJ)QQ?y@uOezHcQesEBnBQPAJ{p6&{8_C?da>Nk2wcT@s>Fl57KAli zZ>@v{{t|`ch^~Kq3SQxg;bws%PiHGp>PShTV*Q9?{kI=1UCL`p0w0HDRm!deSsYqPY41du`euP#$%% zX30j!h+N};9nPp$CmK+lf2#FJsibm8&KjUZckrM`=6KRu{CwGeffl1 z`5}|$+d~~Rs{MWfU8|MheqD#Po>n1_N{(&wMk0DNavyr+E1HmBbREL(*54DT>{>Eo z^-FUjA%k=fbS?T_HqHtGKA)ZmATqmlPF@~sM-7a00ihX~?3QTCh74|U28JIbkIhyX z!q()fL6TO?5vd77A@}|X9-_l!HTUqs!?l{GSfe-=!CA~!PH?J5dbGmJopl~+3My@4 z@@cV0)9K%438Fu`(WLeQvHWhxlfcGJl=JOILir2sej`#PB|S<3Brz@a2FR7D+Y}0c z(!n_o#aCThuSQp`5D!3I;Gpq{=&Chy4g{fbFL)>rl zc&o{742W%L4i^~!?BhY8Ba-X)j5y(ND^I^mJv-QizuI&H?zPu%u)eYa5jKm2kWE$1 z!E?T7Rj#!aQYJ_N$~|&k@H;1MbC=>xJ9qb#*uHmLBXW60R*14TSCFMu$P%h-#lD?j zMR6hUQixJH+h{Wpu@xY++_2c`)=2DD2*0W5JUk8!8#RIe`k>f4#M)TF@qEnM*b>|9 z+KlO3;nl-+feQ*%^5ei37T`4A7*W5p{q931y*m&9Wn7gr!m(hwtIqHM?O>CgOmS=#|vc+31<_2A`&=)M2gQY03L@Hs=Ogd2M zHVb@Wn*U6PWAjYOeK-7jom(dl%!_8lcHgw5-KR;Mpg8IN2Dp?1)C{u$Gm`>yRX7oL z7~#`3q3&&tipctVE1g6zRx3ag67Vmc|9gS$A9h>aJ=u$XVaAUD_-XYoCkb$Mu(P#t zvHTZm{v!|1)9n6Xj-L=;+$YNuSUZ-pqXFWxl1x(w6_2H8EE?|LsPY&Jsl*B&(eCxYo{rGDsDWEYw4jw?(_6APWXeq#{@~XoOv~Mua`7+DULPh)`h94t1$jMu^ z8)0Wpn~GY}7|bsqU6N_eoy+^=K@Lz{D#ZV-zUOQYsDq#EYvQYuAtz5_o7A(&y5{@)5)dC*Y*d|NlQ)M` zw-XIg-T&nwI}}ms4g7*x@7e7_iZTl;&{$ldGZ{O#-pW6rU|`T88roMn^Z+%~bNyy@~) zM~|BM3|d%&6;WzqC-E{vO)0Qx*vxd28Q^Z3nDJT#u9oQvy)KaDPZIbJbV=kba){o$03OytkIjY*!B_v7hU-sj?Y&5XCv*hOpsA)K`+ z@j*8WySDsrQoZOh5cR$BROreJ)6n4g9O;*vRU_;0z{C8?<)EXWL=j-kDoS9`LRl1<%vp)G5iRx^CwI3i?E&X1 zp7JF;ojj2DV;rPcn&xF<$HxTqdTSO6q`20Vhcv$BP>Y-9afErQ0s~DLf<J8G zR;2fcYmb(vv3(p7+IrtkjiZVZl8@Keqv?Cpn@K-Px8p5m$TiunLD;vpT2IurRu}l< z--aCxHMw4QFx`({QEW_;rFfMOk5uX78IU*Ft$LhA9_taS`W?7+_4PQyj*DIiL6=a@ zdZ#WJt-NjQ^Q5NpS;l%wf}2MBWAKY2`u6PPG(1x#A|mK^>~A6N$BjEd<90lnMM*4{v`*WdavaD<$l zr-Vd4|I?Y)uxk|oxi15uKtKS(ARw$DkRarCKx)HpfDAi_Rn9Nk=ydMnVl2TYgAuaW zvcw_x;@NhmyIKlhh}ptKiLZ*A&7hW1WN&?T>_!sExSuV#W&J4n^43Bdja%gjy4IcfvX)H8 z0P=e_PJ)>p+RAh@on^Vk>?*q%Sy;!+gG5K&a5}cp9R%H-KFmAi-j8{2?~jACcVZ>I zOkYnIcPF@K$BmbpZGj&w2JfZ;vhU=x8rS?Jw*>KJFV-E9-;7h^^717_sa3z}< z=9T_9S+ijTL(10+VG~Q9P2nTQ_46qfw(t9!bz`e8TOFsZ;oO{P=?OG5`eQ@!s1o5X z9SM>LT;8=W>a{1>85y-?^Gxx9uh~ljJZ*L5Hcp?SFS{uL1<(|eP4vY=# zr<{R;&|QeCC{n8!SuaJy^;vP{9)NpPnzv5QW>z12mtwh!?a(kcQkTGHv@m*+*>kJ; zOcvvGlLJyny8QbSXj%IDXkw}B+26;~q4ZPftkLOQkyaBoiXSS(mXzi<$VwM` z?8%e_Zc&419z6?FcjWH$5h=|5U4P;6Dpgts3+$haQLQ+xh2^QW-HQJr;Q@Y^Yj}kt z52WN8q77*N-d{?H$nT0AvH-;DJGQ4A6+8zG)?_FMz1TEnWR;F<1~RtaCH@9ib(@QI zqeJ>3K&aN)E+8b-encu{PRof3@pOZlz)-K|y<2IDmT(M_rCqJhbvy=x=V|R8)efx; zdRcFHfTXa)z0lkDviF;@HjUI^mo(KUt%#I!XP+LY+V~WHQ`sDho&q4zEs5|rtv6d- z<(V{R?9am6iZxxlBomN#|C3?7V*>2dE}9X=K~tv{Z*(=f2$b;oVFd4ruSWZAaRmRO z!lR=7;(62Ir^S8Ng73%uX=}EYg!gI%B6Fz1I{Oliz_?gv1=w)r@YbFVw0~l`54*D{~*r|;BqS5Fq6tc0Z7@p*uQc39$y0NOxaq!4wnEIGQX zCW_a9dpK9t#LIr{UP_K=Td?P=?R5iZtQuC=^IPU+SI3t!(OIG@(j@N;F(VKks_H`W<9)$Q#)vSaZxD;`23_ z%1>>rc*iGi%Sm{vzgK*ZbDv26>&qKajgT5aIrNw27NL@bmL9j4D8VYMl9{FDp}~Z` zWZ{AI7yR3fA6^-No_lvwY#_OE#k-69v8#rz!0=-SoVU-rYQAmOA%CP#0V?Z?!Va zh3>T;64*X;bJmaBt)q9IpIIe}0R_mScgk0{8kxizdvq<$pH=U;<7N3DLXY1+LI1Zk zA5Q=$YJ&s;8DabUk+H_ zxR}V-j-saHGTp*^{3&GoPB;qLI#PY#8$=yaLQE3Tb0Z!-$W3-rU(npGGbLf3IgRv@ zGb=xZ54f@Vj72up#?R%4~>1t4^fN)?msTXSmPejSsHW0_X*Imhna zmE5hHPO&lfp4W1nTif`7@7Da3UYVYOUm(S<+|JC{AIQo?4;TMgLqp+;wbhT3S>W#N zmu_~y+uwUSgQ?kWyWSq<88h7Yn!jknjqk{=8n|TJZWodN9WF4r3{jLOktfr0f-!`} z1$f=DsNC<%kS!azV!GjU;Ph&cU&R&xK0Z9b5Ri=AH$HuQ9`JR?7yT^!5f@=It~7^m zh)3@d?eljLgryi&kS30nNl-<=(Z~4$8d7tYyT-VJq!3LwIrw9rJ&lVor56nQqQ(hX z^oGXm@~RUzox{6PhZ7PQRQv1SCP++=0N~W%Vl)Rx7rPXP1N->aVNTlC*%*>*PPRXk zj@*er`SNhZGV+F=Ua?VEuAA3=DkUsr!(5eF1~P5c9uCAxDV4CB&jU$*75zc7MS(oJ zX}0V6BeSGUUS8#3?y9KzgyZ`#Or`aJfDqnZ^ zr+Yd@$nC9k0nxac`UqgkoQMF{?5~QChw}WKL`|wDJX|dZ?VD z7m9@DHnw|wqM@{@L^GMKCz=UTM!*pZ0ymSI=&~he@ZYI)IiTF~Z@21786_h7vUeF( zEe^*+#rqnOyHdU2Gl?EKHaLGBMGY6c^|FqRKPDHb?dnua$Wz9Ah_O58I)!A>lnpht z*sm__KUZ7Kxr#lWvk5pR!3Pdq;Vnl3K6$w7*_ONO5L93P4%4OfoHJK^paHlX4-hnUISrzy}mEI zD?gl;%+40n3g(+>STHt$e2O;JNv(0_KD^bCj;n(~Qm=t5`B@?|s#B^>Z119oTxm=P z;hJJd%qg2HuBS`dOkr|*VE}5UESpnGy5V&+cgVOXw|$nC>(a_~b>Y`49&K^g-G6J< zYtw9H2R0flB5`qiEI;WqS5%;k4oW2`^ROU_#hajKJ9&fnKOBt}RZVJ` zn5+kY5BvMnMRZ7OstJ(~F663umRxbEd!BP;`;X{!eEf`GJG|fgUQ#N%CIHnLx3T(; z{NMDi`f@B%IJVRcUrBf5S85{gFURt)-#i0bnXtb402$!xQq~VW*G>EE^(Vq$z6#yXBG>>D5NJMt0>hN zC7aN*r~^_n1JEyoStr@DFQxRPel(D4vDHtyPydOsxwtz0QhZSowJ_{?U3rwCv$-ezZe=SEV%s5+{SL#WkSTlGSpoL8(SAyL6@ z3q$S}UTwE%KY46C@QX9p5?w3`Z!n48$zWyzECBJZf#F3zFOpf9cYb9)m3RK&bSKe9 zi|_{RoJHrsDoUt-X?%_O13!gPCkyT4U^wgH4)|;vL-$CUwnszadvJyY3Y;R60H26k zf{JOez&keI&(I&D3AI-z*g}wL=<*C zr;Ns-w;A-}-bnNrK56m>|YIq6p) zN`(Db8QqmPcv9u~3TU;2FDumRm0laBckr1;s5V(iMniz(sOLRe5Peo}bVIRMQ5>mG z34n%|)wEtU(1I;x^bKJ6p&Yc#x;jitG-Nt9oQ8gk=cR*4BQfw`7RBwT!uZ(AIe zcT^|?5d_2V@vW=tMNFt)kBU|T7A>DuaB_p3)7P^yw$4gX0O6y5BM`AIDYdT*n?$Zl ze`uHGT{e#+gFz1g2))v2ni)3-+6!~XAqCOpy2B{SQF1ATQwoCGbuYhV5(88Q9`USI zVPaVtTLKo%n>~SJ)>>HfbuqSuzPkmf+&)w~5Xm5u!9x5tU)?T`jnO~tQF17f_hDeGOT$K zCX6wZ>O^=RdVF@3eY0`fV*tKvit_`zT(T>?h@ot;x-1KsK?G!gL_yZwiv99It;OAI zl_162?7ph!|0(0#qoLa3IIg`e-K#N-cioIpkw!O@_jr>>-bN8htF977AsJ(snaHcB zY>LuDC0vQ_rC3T{(}QWGB|TI`T5|K4VyP7OoMW!$tU2??e1E_5*^fW=nYGXSe!ngH z&Tm(O%&|T>8@`N&U*~6bXl6;@E17y5GCL&i$?GO(ce_G2b@SqJr+Uz!zvwkfqb~Z+ z^*rPJ_PW-7ua0h4f2Yo}Ym3gYD?Ao5_4QdR|2pBqUH+vgHM2iLH@ArPM)*7`Jmhvo z9OHC?)xlN?vjO(4qFxw7?i0BeK#( z{@vXXG2Hy1o7Jr&!9C3mD!_JF^wxFxwFeaX+I@=4du87$4h!>ICl_qKwNk*b&#oB` zDoH4dNY@;byW+h%L$j|#Pj#vD)P-crDuc(qz;{rYP3XCPz*-=mAEo`p)x1~z@)i2B zyMLZ^?ksw7wpyh6)%1rh>j5v%C_i4l-aDslh}6JsTGA<)xfSX6XjjS9#6t4@!@(`2 z7;CTTtqRe)ZI^>;j?{YepBLN<_ZTr!d-yD}n#6^P)!O;u|NU+CKR8(89KDEx$O_ zOk8~LBKPT#f55^0WjnGvme}5x?Y8y#wRD!F%wrAw-C0zijReS2H;ID%RIS28ClB8o zVZ0;Pc(YrXry^trbMLQ{+o`7Pq;#w+!TP1^RMV)|=UzjT3HR?IpJLT?cjgQp-|3H=;c#QYQ}lBoI}r zg+O-jF-MIeRb7n(^>m=f%?K^FhE*{H48~PA;^42k^Dxpgyd6UZ160H{Us43Au~cx> zKR#vZ%5 zhNS=>CQ!jA2eD}n#vCzO#xe$(>o9pNkp%Sc?gV+t2H09BN%0^6<^5}p+Cs!P#0lq)xJ$;Z4 z+5<4Dl0pN%n=qN4LI-bA$pZs{*gQs46<}5>6$paFragENES3vl^dTCE-7I0s!J$LO zVA&SLrH__~!7XV7ic}F9ZrQBgJ`bY{5`}Sf6*%}v7;MVWMN2H;c=TM)xZH9a{32o= zMi=ClG%~P=!dy1#dP-(Ew)_7Z@^ELe8U>#^iv}DdFYaEf7bGhVdn`~Gmp3QL%5=ug z!{{u`GswV_iMf(8bg_YOSuwb_|0IaP#n{7&4us40z`+)Y2)ueNw%?Te!N3P^kqs)Y zRXqo7C5yG18$>GBBFS$^MQ{p?%GAcDj{Ad4l9Qnx7K18SuhQ>BlJvT4F-(No;UxHP zCV?Wgt(N3vf^y~?IA>{6q_$ExxF#1_VVda9O5N8(76~CCb=kDO~~v-H0?uHv)nZA_#(ngp>#ZN(y%k zpyJlO&$;{j@15sa#LQan_j^0mw+0P#=|$sX=M1v8vj>Ab?c8iZ+Lrbpdna=%Fa+cb z0Xu^ot-w}nAWg7~yB!4V3IYS?03TVn+u6I>If8&|tzB6_P7siXwX2X2l$4tj$id0o z(GBEj3ndD?}192Y;JkW+y>0*0fxBRIXQx?o$R6T>|8+r0#|bf@b`DjT|sPa4rk2#WkDOT zBN$>1CF<^K=V&7YK!lPO60*0m5E61QzXdi0Fqodd3u1M$wsr-(xp_N-LFN!kTL30V z1o#{(B{7hQo5R^3zp!Ly4e~X#GK~2i|iw zce7;!F*rN9y4pd{aW%IF1JVJ`as~lvbA#Afx&fkd6=$UWWl_Ih{(~|>dw~xGb^%dS zgKpmjQ5l{w1opCXb#n!M|NQ?RKQ-tVFuy_r)B)wy$_@fLhXefO2vz+LJilCgak{Cw zqm?OOHW$}GoSfXwE;=XSW^QNy^Lpc72-uqglC*II8M->#+qs>c^@A9z@rBsW2wYg@ zFIS&g!(XKaAZGt=(oodj>HSfXu1@X{%X9Aj?mG6%L;$=01%V$3Z0`#GgNf1nW;;-c zxB@-~SdA0N6AZF6cLex@da${(GsMXmVh1>mz4tHVp~eb)W_fO7u3$?ykgp_2>Q6Qe zJ@rf;_V!>$8z92aN*aSiML`_E$q=xcJH!#>>-Vd&p_f2kzg{NwuP+k=8D3ia??6IV zgxU=>%+X5z#xC?@=nHy^B#2h(A5V}1(E?=tc*>ty{l2j8pFg&Cf`H9|*y05s1NlNv zW}x+A{9D0YI$i1yHgL|!g?!JV(}i1$p{MC(j>l|I>v5S28yK4e?KU z=g|}zOkJTY{7%o!(q2f&%>kM>T;2Xa>bv0WElnMuWI(j%Kra*iJ?ul5f`T}^cZ$EmhhF`QrvM2D2>fSGd9nOoF;*) z`#ZmgjrJEl{?-kkin4aMx4)=LK!!J+fHK6;(#a7>|Da!qoaGH5KSL=SgM@^j973-J zon;{>Yanl*l{O%tasfEEf)+I2--4W%Tz};4%vhiy+7wvwBB!vQ3;Ya?FO%P|K#ZZ8 z2RI*W#R{kbT2x(59>1;ex7h_ zABTQ?Ru_M-Z-s=epXEldo8@nypxn}c&7r1yQ5CofotMbpuR6o!3>b_X^nIum{Fw+) zqyqVvi-U`sl|xVn^ed5zE6YTv2t>xcZ1p$i2hP7LJt(?U`LP}P!&Q$Hx`Aw<6|e)eBm#b0f$hz`T|q!0?rG;}<>cuKa<(^j10o+# zc>~p}qmv`+SvoNXSYZ4!GHqLE@eW)FBuRG%psMu-vI#)sT>9+nfC8Y{&I?!|IRNhi z9%2sY)6LTfa_g+z{k2+ziXQs<;TdOg0WyLWQ2ByxfdRmVzZ=Nk2UBWx_H$E$R$1qc zMh$YbgE}jM1sndUyz<)#G?*$D6 zQ3&Mv-{z4YXaSvpfQ}ZZw(b5A4ODSd-+Rp8q5V+F59WTT%kMvefPy)bnyVWS3V*hs zu0Z=KCMI^tbT48nNCc`Dpc($@4`Lu|Ak6{2zLBE^V2T$k3H|BX%NJb`a&@<~1cQNL zgAov$pjFo8NdD8_e!3&*2YbJ^wBO}=`S&lZNkbz$G~l~C+d#~%&gw;A=m7!z+75_* zK==pD?mXyQ+j#*7c!mV($p5_1@8!jJ2!H>{xlS)z`0r}`W7GK8=I=jh_!kkJ*8rgJ z+C5VTG}`~m#V-^OXzpB8XY_#7XL#vf<9`<3FTuv$@f^_~@cg5PT#QeC&Pl9+1a)R6 z-+OK7cnGMm02etM!ki_n^YR5md#R}Vd#ry}rQe^U01Xg}&PDx8xdn1{w*Wd3plNmj zT;JT@6Piw;sSsLh0O)`T+mEpm(2@h=2WU%vUXyr$9qoYAfPngQP6kvzQ0qOv6wo3x z75`CA7ej@Aspa2D{$rI$V{LA4Zvm9IP=|sBf573s*HFJvf;tL~suUaO22fs{RV|i4 zT@PeWs3^{=00*!YbPNFk+|_1`1!U+VK8O#PSP{;WW8wEsffx_y1u6s`M@;KKV0vO{D@~jt9 zKN~tit@2#-fNh@5jIBTx-awt`=nm-qVy^3a7GD8Xodvlcjt6aY?17mR+uyqy6zyM- zY6Eo6rp3TW83fcuKoJ4eJh0k@djO3Vv}6FNn|~h)LyPR6vt%fMA5y&VwX+ejGr%a| zeiyT4pd9-S^`8Nrha6f!lz%j8C=dVWCeRb0ud}Ag3S{`*MZPx--%*^w`PE?mc0nk; z|H9(`Z}JLsv7exIE+RLr^?BU=1@S)uhSK@}A$~)b`Ev~a`%nIS{$D1vfTGUZg#Svc zzlq}4HGcgMdWYtR!2<>g1k<0RMN)NTc!Vo3Ffb@EQHVhXz#lMh&>z6-8gP8iKW`j5agek@=fY3{Ba4Y)gzMi@Mqk6N4>n=LHd2y(C9?0sa=9HrO59JM<{CL zl11$Hg-RQ4OEu6rj6FF`Fmrw;6WKdCk;HiLP*Cys3tPjTTC^Cxhm7GO<`3uEd64PS zD^_~C$gh$<;l0g-Vem91a?>g>|8sTi|z%3?2B##6?lu%2Z zqu^CZwV;3SIYq^WG-5!BftT6Hgn6n;DJTdm7@BCyiR)i?la5cJf|18l*Lne5JkI<; zreIrO?ukT^(d|GEwn8oQrjd*o!yE6cVZ4b&+3@RVd??;}@~*acbdJAz9QMs$fj(OVUG;&1;9~5fVJVZM>j;b&k1suSzp9;2GIr<8Hes*kV^Ut*A{P zEjb|6fRbV6xx&52?hQ4Q{2D=a_H()~kdBl~ABc_{l#|t(ki9c8HTK`9=^En~|v zvWAa3`Y^vRwlsiP#MpZK7zWHrkvTh!g+#P@Qom2upLmk^rQRQF>2Al-i_}>&7t$)^ zV;$xD^3mn5-M^-lX{@-`;dV_|(FPYY8GZ5TeA>NA$z!wb`Etz_Mf`(ofmLUG0s2?g z4D#3pL8KS7If$=8CA@^3rnc%~E+IaTD{l$7vUt`i7@5nm7kilBz9PHZggHI_d?xGg zChF(ro35?V^9uFo&4v(@5QjX&+%IeSNOrfUA_p{Re6NbgjSygLcGU%$SiJkNfHcfE zn3(VRVAbjqZwp4l49~6dowv5Dy7Gp`sPrHFyJE16MZlV`lG}N7M&Cu%->>*ukWM;8 zra_13C7nDLc%MNCLmLY@kbfxh1Gp``?d$IVr!wzef zvx#5@B*uI)Y;h5IZf3%fD-AwyYz3N@E33pM)d}T~4)2tKTh$ofdX})I*iIK~2xt1% zt=}>|**k=kA37G`xH+d$3vU~g7_c~P=1fbt{l0EB z@N<(PLpbj-W$Fus=@$j8S(p*V8Si+|)H68-Jq>o=Hn#bJTH7P%*U1N_9* z^QbStaHXBaFIZ=!>`KxU2ejKvXrk&gN|i_p=UV0O?+0*Hi1HhL6s&*xs_UqlQ$br; z{_Y^^tf=$VZ+5=l#>eKW1R-7cjXLe4as9zr{XO4(|22NtUAcOk}Iu8PoU|{N*VPH7^W8egP zutTdNP75v$D=QuWOHPi9SZNBxN}K?XJGYTld50YWDU?+wwPmjc@gbts=qDifx^M>) zGNxA07Skq=Vs1}+=2`Vs(bBsIvXU)|Oi*oJjq}_Sp6Tf5fYlU16FuNviuBQ9d5Fz? zJFtf#@yHi>;7X<%JNwYg(o~|XqC$%{B7H_W=MF#U--~5DI;(T377@Yg6H^Vy1 zRLdh+n)JyV?okxxdA*Xw{yup+*H$B{m`iTHK+<_E3m>yzuat*D%s-63;p=T*~o!M$j2y`-Luw&HwN$N?X5@L#gSQ{#ro#t zr_8K;OpC58;Ws`%n;g^TBO9`*lT+O|Y15cr#VO=`h46H=L`xeXL~?+vLc1*>4w>== zTmFY5Qpwi@!n`jcW8{d)$38N7KALB}FFr`EdfF1G*5KRm`oWzL1l%=ODcqQW`(?fi zX3qG`BiZ_q0_L!}2%m`sX_jp{e0VE*Z`5wYnl{SQ?4Im)$vXtU+D_?38_}c2`ZOxI zY^iAMfM9T>P#j%AEPsW9(%(iAG~H#B#rS?veP=a56Gs;5?Yu;4=i+TM?2Y$cvW=BY zT1d@zE!^9;?-xGp>+0`#6rG6nL^~%UE?HdOQzxhs5_C-@n{$oG24~!Tq0hecu>3mte!zhD~V9Uwyr@O>aR%Wcm3GgL>NQ_B<}rEMW;*sG;20@f$VV0`6gL zk4SdCpZ10O%lbK(Eo9%wd9j6~U63uM+W;3IB5gPJuw$I+on+JmZRkW@e>=y4mGj8$ z)@ObjF#AEg-(FWz(#sFC_=7N?)@a6xE%HfXr{hC}vvNLXeaXk6$Js+zvN%i);_oV- zzTq82@cCU9hSVc;s{;{C#bYC?J4A^Dj0kUJ@783|=q5ecn&>i|cIoAZH1KSPZR+QSpBoJO9UxW;T@wOmF5 zHi*5jaPNl5llP-)1XeFkGLn5E(hnKYcO~h-Vf1yvxW1?XOW#wqkf{mKI zYEzH%&h%5tqV^qK1BxbD>5cU{Y3)M+*j&yMvEOH+jq?NMcDYz+M z;$-)HZoYaL^XVGlNlt6gfk zxVLx}o<}SDX=eeLwK(?KBOhU|jS!^`9gn*CfVSyiYy!X6z1rUt9+XcW*High*bcbX ztChW4x2co8o*rn1!T!<9Is?zUAC|H6PO^6v)isT!>4+-gshTQ{(l^8Of_Ee2@={P+ zW?~3b6g=nX#B(2L>xhd!+o|kbRlTZb}CflH0 z5^We(j0ffBt>HJ{^eQAvSSS0gp;vOun$Q8Bx%a@XqS5CF*ElV`RXQNUBrVfl$QQ==fDI8*9u`;`7# zoSihb*j?wn+mu13Jj!oA)iB$d7e$Usx1(@{f;X|UVyQljyksDhP2%8SGV&3C5&6Q! zw4$$V{P|Ok2alc77%T1kBUwG7k7OBH^;e;zXw{CB_(WY-}IJDs4Z^f77=S zU|B1CLS)_aRqN44Y=CX8?{QbPabfDlCyptKQ|@ZxBh(>}bb6sF3is-1$J(g@kEXYd z{8Jm&P1E*usT&@Ddh;aHx+wtuXHIj52{JJ2wm>9+hk+R%0)R0lN0!Q zm91t@wlptJXDDVjo?#6SBfU=s4H^x;EZZYDo#$GJod$V%wJlNx@r1~jdI(R)4zTPR zTZ87{@j1v7Y4{MPv5FGponN?%C~~@-IPbGzd7Dw%xMp+sH`yxiAP=wW7=>Bt$EF93 zI6pBKOqn}zpq$IqRt;dZLL$-}`b^~xV}!T=Qj^ojnaswv0m6F+1PebEC~S1l?f{X# zf~D_;BEAEWFP<3*^&eS%^^WsKw?8&ZkHh1WIZ;}4i&R_XvHIdb$9Ebd6$UDfJqwDE>M)Da?LfPAu z=wYw35SX>zxw8g4Bb}+)HJ_6-m|R_RebvP?CFAM4oIy@}|ME0qIJB#o@HX4sa4o#e zALt&#m6fZEnao@bldyh5fj5ds8(KEX)Sp8`Q7PRfAWo*%Cc*KFZKwwy^O+Ru>e7`U z6b*_@la)q~L!Bd7Nr}_36patK2$tWvdbvyaxLLfF%GNPAw1-rwXy3y3MZ1rL$a8KA z*igO-pLjoE@icQ+_>LZ;AycjPJ6-~+eK!~Xvg>Z(EMwjGAH=~Mgo7C+E*>4C;`8en zuWG^eFDBY-?5{MdVbCe#D^rk-iP{fpeo1${8NsS%WBcm!_I*84dmdYoBWseT4pmFC zxLYHSKz5_?ZB&+I)G?UjhpZ%TRo1j4=pN-Q+NdYo@0H@0GvVK-n&*Mx`u zJ~|}YA*IXIXeMZvxO-NDd|!xmyP_naRHhd1t&)`_b>U>)mj0HL+O=Go{P586tb{%S z;x-JrZnsy#%c2V{AtG`O8drN(5U@IAI+j;BBPSR4gke?d90YgDqt%C%&;%|H4z z$D*NIJB3mycRcd5Sk!0L#d@8E)9fDitsM?uj-fU3<=SZ?9wx-IB>!?1CQ@gArPYZPJFeVm>!)y zi63&}D_=IB#eni@>vXrESv}FOAR)6=UE(#hy;tiB*ct}r4u)>0)^NZ-BaJE8G zQQ)pJ(0_D>;dz9S(QibOsa1v@#1HOA*GgkWw6mv^Ls}psj`7K6P|RscJtwn`(`}`HWP5&r_h-X(| z$k3!-*ViFe$eiL>r%9~BMLI`TkvH! z1SUW?(P3ctVUYfFwEk&5rsskC!iWGGup7FDx28C*_+u}MlaEMb=Z1QGG!GN8f1=-2 zmBbguDT06Hh!!`Qy>f|9a=&epp>{!esv_otIgaQ=%5M7RyIm65mwsmGA;dQr<8bqs zX|Lgxv56Vo{^-$|e&^tU%uCsJ`D^VQyB@7sjTBifiCGBI4~&A0v%kD!gkih)2~XP< ze^md?&;Uf!C#-d@kL$$%lfYgsM+#|*ybZC95D%u06{iii{usx=pJDhWpBv!jW9F4ekqq35DnLl`qKP_HuvsV6R{x zEz!wv(<(Xa%C}uuel0fliThcR6`*W5bxKrh!rlIa_}n`fT>Cn*{;Ju9xVuq#LpIrU zj|)w#??x4CE}3bB1lCPc&%TmKFH=Jnee>eEw0f8!JtKTg6n58x-fZzP?iKu)*F3nP z!8ujmjNfK*4;4xC8juj?bt^?Z7?QLLxWl}1>vc)`cG+WdQZKF#uWIa_o=V*fjL6fu zhoMfp&+bNG zb-hTkR_N`Mq$iD8UfEw+ox@Zb-x)76gIFM52cpf$Cy^R;-SoLW?QHmoVV z#9Qa9de*Z;aKqFA=Fb}AxH`~ajdG^Y2pBjfVZgxf{wJ%20FzcLV56Ti`;Wga*=+s| zWv2x`9I+d17ECXktBUYw3#IOgvQ2iu$u@~zi6tGz13$@DU{wU;Bb;oeQ$4;9u460? zX1&KfdwYkr<*+jb(btU7px`>|o|z6!Rxu*Kx^n$k@xA;p_oJ2Z2P_&H%EKZ{RqAxB z91CMS{OJ{{32hafkv9?%yGXI>YJS=;w3hGpTf&Su!aQMQ3YW5?!zB>wW z@A(jl?~67L)pk86F@%&-@gau2OL;nIrtA;XibpZ=rb=_JZb!uA=BEemP2w=T3%BrJ zYo$u3gl>>GGxgz|SiazRUXXhwT2Or8BumOU8&vC??GdjO8e1D=4yXC-?qcH7lvT}r z16}leXK60)#o-%R8LMp*f*5V@5sysubr~2r593wp)a)!CCLJTzwj}0?zMt3MB^G?Q zRA}8lnPw0Z6c#j2{v4${qL=3 zN>g8DVrnaO#fvjEY>rK3+cDPcQy|l;r&Z6xBr{h>BrC3F#0Q(!Fx5Ydi@^|e!?7bB zx|#9u0M7%lG?Lz0fSY;r=}%mm^en|ALXL#?9A#%Ba9S^W?cF#M#bD&2)~& zknl0B+iCUHhgiZ$xmP?#o)+t@!1hcwRO%B?*00VpIt0BMSXo#TXigk+=wJ!k84z42 zZZ4$r$+Qg=5roq`PE*r=jqi0Tw&j7uw%sZM9UZ$_Nfs@5UcfkdEE` zSoZD{Z=N}g$!S7as++OD{%KOFxXt?Pyq$^h!LzHg-&8E33h!B$OY5m}ehasHqcbZZ zd?H?eY#d4YWm7{d%@S_4N&zD1(Tbt0ss)KWDdBqedjbbMq{d}jO^cY@)SCHw z(fvb+=T}yP_3g$)4s&4}7Hyt-cy&K0(j&Oi+3!u)H6=V@t^d5_1FO8LR((?&LqJ>7 z=}t*AneP>$69PO7&%xRETwLVa-=10-bqM3*Uo%;;2nl^pB;i*blRWH6zcYo+MK${w zeSGDMm_Lz9z``?K>I&R2@?+$*fF0ba>iNU8dr<@(1}xiEZEbXg6&kx`piouPNKZQk zjD0EhoFp=IDRbod9EeL^&d0kdC_|Wu7IJ+o*^`;Vu10+BbHWOX@q|I#5z;FTNn-QI zsI7;OcR1jMO7FSwM}IRD0KLw{#HT3a-%LbzJlOq2@$FL3+B9L(FYU776$kFIK!8K# zUj!{v=D^T%lv%kB{QRLg-*C`k!}&pNSF{>vP8dv zd^VZ_3G?XM7K9N5Ba1p`Xoc5ln3=yG-65n@I~Z%$8D51NDI47;m>H>EbFJJ|AFl85|| z{n$r+@K9QKZI8c>rLpDfNTbNs3=*qoD_trdhq!FKaLq-M&(BbJs>o%_ioIGYSV&q9 z;&hXWJ?++XnBtB0>U{YP)wTwf}5|R^^L5TUV zhHw-^Z?5~Q&jVE1Rn>B8Y-?#4ZIJ3ti2`9amP}u(f<0XfaJI3%P@`Y`Mm@_o zl+KjRW*<#9@@ej2Y2%}mw>)7vY?Y=dddYg@ikT7SyqeF6BUq(&Cn=?-> zluv`qp`o)Wm@s?YZFG>j|FfAf6K7P%(5`;;bzm%Ti;zf^3YuPxHLvLjwW<%(8BgJVytIl?C!VV6 z828!j#t6&2iiD6vm~g}<^3Ng!0dSC{BjM;&z?VM*ha7PH_hmH+yAxGbay+y?D9wDm`v=OxLOHS~3D&5`Rb0PY3HVLm}XO$J3 zr&(y21$kX`V%u;YA>0%BAemxY6fcqjJD5A4i*dzlchKuhqv1whhq32V?oLEjbnR76 zVt23p%6?5;lUOFe_E+Fg`#)pLj1fZz@%BX zv-;_vGh{~^|7J+Iw_@66I~qZ^*9@N0p;U4rY6&?i9%GK*xThCMj|gb$!$T|+x z25mQd9J-&MuAi93C&TQt9=-Dv|5X-C2d(pbfDE8!@IS;#3t&?Tbno%cSovhQv_?ls zMM-ylzIa%tLPuSR6}GbDWnS7d44fvoXMN8H5UXOM179B7#}_4VD%5j5C4LTjDSklh zRBdwuEC2x01djh9e*6ONhngg`-N2@2oAgZ`%ptc-!4A%Dz^vmeO#(60 zx6N1l(!x*?3FN~|r~->>0f)}NPtAW_7`n~c6uQIVQjW&#>%hDN!ay8u(mI|a$I`M7 z>@mP=hp+Z_roA!j>9_f<#05*zfd!NPDLfAj-IFFCx$DHT!ikUCW$P_RPc@#u4M`x| zNMx&S7$&sP6Z_Q+Yo}PtHO^Rofie02ij7OEht?dJeFIQ_kcOL3g>QEVk{3*D<5$wE zW54{+kzgb_`=w>CI?OKUjlPiT8uD`-T7t10RMt)iNq9b*b_jCGw>Xu49pcBY**+J$ zH-_?EZ8p5b5+a}(lCMVNrvOVFz*=(u-Xs7efT7!UFV`V436+k)KpoZ0t?>QqA_0KC|j@#|3Yr^zOw{=)44X#8z=0omOb$l#>Cg2SNBdi1=Mmn zccu|#-0pmEYM}MoG()xi_z{j(6~XI+_s($rM{4_5-*Q_ByD@4Ei9kKZlt!Ho^M~GV z$W3(}-syd|uwsV4>5kq@_PSJ)H=il?p$}@?12k{NR@k4W1C?{0#3U60;2a`=oYnrl z>HI~`f3cMx5~rPcpNC-#$CZalg(qED?0es%Y2un5msm(#U|l(pSHUN+J&1}-wx+uFjP&hv+@ib4_~M7)Yb!2DYnbq! zq%4Xx5)SLU@Ir{X?DZ4TZli*Ol9 z<_V?noSMK2rH~?4%Bjtca3J?2i*7lxS{~uVs9HKbwNm!n4XsW`X?{pA5c@uaXvEpg zI`%$<$1d@j|89xs9f4*M@s0(hh%BBDTK8_fmRV>PdT`sl#w&M+AHq`Q#6fXO)_AO8 z@&njieav6$Q*!@UtR)LiRxcLOyg^=Ns;$|xCg%JI-a+;>-U=-xFcl$ZO8X}mxk_C4 z>y)xcof-14tcUHbTxOB(6~1ltb)%0=Zq2T{G4sU0k$dIfZG4huhuZN=sZYW0MrN+z z(fi7^k~-MdsB@JBO}Sd9W5r$f9SPnKc3(WzSi&4L575sx{VC`gBUXKjapYUVC@?Sq zz}`2Re_upj2%76c(r2~vQ#}W#DFM8bGE>fYqOH~mgDHp!`8&$tTVzJqzSG^;qFPL> z>T6`C-YMiLYq~Vco*s!xD|sXm-bMVBNEjgl3FF4j^v?EaIo(tnU4Nx)tW)KoF`E0N z^h#aLcucm^7~)3KRQ!~}BuW!iQ+Z0G%8C!oUd@{tuEyA9U3I*zIG_}#OiW)Ynj7e?}2K!0EVkhapJmFwml$ zw}7(co&~pA2qO_MLG%NQK+2ZnH+?zW5B3VCM1_`IJBC-M8u>d9M0+P&{YzjG}2g=O+8FA zjac0Z6gbMX)FVOhqe3fjY^BM%#W?R1X+Iueb`I|jV@_w~sz zoza;>@V7Js)EEL}ghMUA4Hq2~QY%Mb(gmU_JK#pDm0ITX39)nPb7XJ#R9s<*?c2LL zdrv~3?R1xt_Vpd_-m2QC7<{V~_}Y!>Ng2^`OR1!WdX#&E9G=?GnIffowN{@CE@8qi zJXp?pCvQN7MsaV`;Kt`WO1LxrNCv9oU9)+Q^CMQZYQ~B^Ocp8Idc!%6ADYd3V;%RC zkf*4Lwj27)>XQ2lSMFKeQcEf^wPm+uEa^wq=FQjYis$N7c$~(QL(VZcyk{mUd~XwqeYs`Xg>l>G#ijI`AD1 zgQnH#ss*f)UVf9FDj|t68LB#zPe)fxe%REgGN0?=xGI>@^WQM zqM_h`KJAo%)VEHjlW}4@bGWE2N&MNf0n+^4j{Ynf`k!64BhZCL@CtI{Uv?SbtrD0E00O@9~65YdGBvEun!VlP4AZEb2VQ(D|x{$<4rbH%8Lz2Zm) zn|zOaLkkQblv$ZibyTM*ZqaUW^d4A)jF?}nEew4ga$^K)6*e@Ww z=^`^}TVes9*3^NR|MJ(v}!S89G`1^>Aoq* zFZ^mt`Ev&8NEp#75pds$Wsg(OO1yTld!DZRNeLs8zQ^wtVuq{bV*K@2kjGEqW(~1> zqF&jK9ynJi6jpazaeXo(VZRpT#%Y|k|9tIfgx6bvc-bqS{b3$+`hzD`qn(}~*=@Vy zjPOdT-rXxxS1jr#@GEiI<=ubibh6%XtLy2qbH;29Nwq9WdMnC+D+y1Iu3sE}ryPS@ zJLc2-y$_LQ(iR!E?qDx0!dO3wE?l^W)%Tu(BnG=Gy+3y`;@FXERi<})7sT%^nnu2u zg3=@1{~)WFh0U*rCMLT`SJi_bT+uQEq9J9%M0u3yMs=x!o%d z2e+L_KQrAF8~Dl@lDhd?FhOgm1{(A_%&Z-!C;xBhWRqw z6@Nv?CU;yl-!`<^&71^N$TWNEG1L)f%4VwhsDRs1r)#Omb~$dDBO`qvEcf2~#g9I2 z9to;!a=8IlW9K^FF}%dAWRS5wTte)7d0Mlc(Yrv@6W$Uh>5tMX)tr8JMv zIXlI|hJYIBc!R%wbQdK7*@y7CasDE+_Y*DZS{Ywl8E#Wlt1mZNH)fr{&zI{{UF>g= zPefOk-HY9taaI-~QCHf*8Y7FWBzUyu#V$B{VCOL0-D`e*Z5%=J(L&GzEL)+hd)^N+ z#L{CCZ|QB9i}X;hg{BgntWO~`xa6*GuG)Xf2In#l(CJp_Y2~T#G^T-PKww~rXIN**)Gql^6lLual*^?33cWmDxY3oow zoa|jf)HP2J|K@Mq0Yod!D&%jckjiaV5Bltdl!r3dPOG*Iv-?%uAY!7zf@(H)N$Ysv zb!6+tiC&F8++f_7uS5hsB%Y$-d-d3QmVr`m>1QUA?UK5zWu_flbE6x&uiQZz4vSrcj4 zt?$|ehb0+g9nX}eOy)c1Zh^sspQVcsIzaHPb}1b#UkXE}P~efUWDN^x-{R+n=HK5u zCe(WQk_~xsSTNHv@4auW)v_Ro0+Jmy9mn&4pLH3OXSB+jV~GI2qrh<;IR51j?H8VZ zbRDcOMbUsN7;#Q?P8fv?30?U_QN-(`po#&x0g9rc=a`cs={}?2&Hmq!4{NJG|>XA`R3HtmR0jN9ALF&5@X#2GC&yK+S7Dyfu<8^M;C;1`F;Md4Qq$#t$)Z1x zzw9pzFs%z5691lgTXTrj+3Zkj4w$}Z-hs>Cj(&#cONVHPnE(7(Gc@T~eKg5S`S|xidqeSCMnr=oA-B?^YMx@oQvc|pFR1DH% z7&|M;G)>Y)Il+9G0oWsz$={N8cmxdl&{hqtq#m>02vo~@8~db;rqIe$WY8r3@k=<4 zR-bkb-$we+%z{}RK_m<5=_RpyCP-Wm?VNN2-6pI^u0lSzGaGC5%<4%A z(c5TyQE4PH;AHHKCzc@SE?rs3Yhl&2to(G>lTj?6JYn+qYl;%jw*u1r{&u^orx^XK zCM4tm`HDX3%e{@dGw4cQ5UKm4D`AqkVS+G+#Z>!Dt2X}Q8+unC;0cF4_o8nw>CnJ{ z;NvS=x_mI1bx{zvy4u0bOMs^$RD(g|y-1D3Eq)sA*KSovD1FMR+m5AL6M>SbCRtVO z9K+};5W#~HQ8D@Too6Ik!jM_1p3e*yWt>E`XL+ZlIOfNjwzo7^GuMV+o9Aqtu9;?{B~9Qs4K6!XB9A^4xE5o>DEPx!*dpBOLUCPbiIZ zQbEu$$-!pU-ppYm>KNt95>l=%~DCp>^(61Py`<-W$wtKqE9u7jrWK) zBUJ-`rdPJ{| z8_P2VbT6ylMf)Kpep=l*{EGf6YxUCyxleR+#zK(B=o7eK!&jP7GeQ^ODA|CcX#D%O z@;68M5yCF!tM1yBj==t`Y52vfWutSlE(x{Dfk<*;7>JryMZ#Aepf*3OH2jQEkq&`0mA$Y$Rj54X5V>yVnHldjxnVyb4~mMl1bl6_Ybpvwel-vHwRa zby`a^rPMSmNfIU-@;DQ~{PUQEZffo9fhaN|X^;#g8)bdCRz$q?*L^xY>REA%e$^|*bRB~@aMrQ2cRx2#c zTCKMnn2n9|PAv&m)6z5+6J#W*k)?V}(M@1``Wda2V+OPWDtDXeh_B))j0!Zh7QhXN zKOybl;`lVZDJeM39K1fnqlk_AO;4xaR}wupdYEaf(fUJ?MeJPLW7H0%!-oM+JW66q zq9~-3TJITgEVC3eC@YNU88sI2D~))*l|NxoM-5TDn-Y;1u99a@xO%m(j(B_2;-u{v z(r$JXUxIXGpP~n0HZHexyaIQE!V~+U(!vrPUd%Ul!GrCDa zRylg*&k!O!EnLvXJamQ(Ysg}Rx?fNBcz=BM2s0J=+o)ZxE_+EGZX3?Q0V>%-c0Nh! zc5=#y0eCJ{NuHdF!&Z`B`?Tij2T0zmlc(spXBG!BI=Z`(&Df z`gQqNtu^At@ofE$yX`H~dx^Va$L_AY?iNeNC>qioIG9NHz&F$q^3_IaShsf?AUBqL z#m9nojahl|P_i@knKaK$i}V!4B=!~@lY2Xk91?nOMz>A_CUai7RfruAL@)M%>>sLL zeH|P4{z-z>y2L#9$a(?hsNqB=_dGKfhBLhi$=yfwTz8gX%MSL8?udGMFiEVHOFO1w zcdvKtioDCGXXi9pSw61f<8!bMBj^4~SJRjsH?^)N6I{T4<3?4&+`bSO+~w2<&HH?$ zBqmuv%2NRbUsC@*!vGI^|EzQXQtq)$(2OtZ84%i@%Q>;l-Ibqdp_EFMl&2i#@9%(E z#WM!EDv!cCg;k#7U;~GZnZ?0_$H274MipUgg{LLNG%7!IWcl%p3GonBK|(>s$A`_q zPNLy^9C!x(vS?wVQM&Z>;Pz+aQszXE>y=5`)0LFwC)o%`QN>x&3yy&#)|7)nbjFCc zeA*n9#Al~Ul1%QGx=Y+2-}N~~X}P_C{%iDz!3unw4+y~uK(74nqsJv7{1!JZpZS!1;Lmb~Ufk#emDMm}Q9SNTv_at?L9>zTeS6PT&51+BA5lbe9 z#CB6&gw}wY{So&2Ix`dzDjSPu54{*~QBRz(H_0vAbx3{=^VmQlW#_=kklMz2?v1rA5|aTI zc~Hqd5$95j;o*Zqq~H-PrZT<cH$2|n-VtKo zNz6uG53+bfL>J|I; zzU(KMsu(t(6bJqA$6tKSrQgdLyElEB_!@a2ccM{4`&=VU{niz9oW#RBIVSB1-H&f7 zSekg2yM(BTMAJ+J+;x=?+v{Og{0Q-Se}APUlP9)RmQ;adWcsEM6~0;XrEUfZh-y~~ zwaP$%HBke{^?!dC#R2*~GN#aHA%L&B1HKU9`wd~B(16t%R9sL3?g?wo&ugl(!9f!3 zlM^M=(s)9j?LK=c!gk5bp@2yD8yM*UFm%8H?K1wgng0pUk6`mFrhdhRC8a7I;GQ+K z8yQs8QczKQ`SKSJM1wh1pcHl41GaC%0Nd7qJA41(Ig!8LKH=zO>In8ce{SUL?#Efb z%dE)CR;i=Js;GO}@u3p=+`dAI11yOJ9E$%w@wnPSZ@8GcyIBidzNg5{s#sm2(^&DP zGbPGF>GGB;=-QNxTy?m>y4b*>`R~o+_qBg$;$k1zFDQQ5*#(6WHDUbb5dfhVIR1y& zcmCy>-_tK^EGK#=$CZ%1lSmp0A^qZ1X%|iPXWfb@3gOsf_S+TSlHc~O<-d0EeAg@c z&EyB^jK zXi?9Kiw6Z>%xK{_-??`!NE|j7J?TY$PH+0X5|dr#u8yPW=mSEcxA!m(ux+FB)TOU2 z^x(0q7av~Q@D63ZNL^$-9bkMAI8^@!9h`l0=nv+9Zl{9!=(#L#LieOjyZ$1KqPv)U zg7$1hr!yfQLalpVSBb3Fk~F}$RtCAjLT|8;B1!`IhSz#r}&b3lVGU)1bmtrn5AX1XGz-K7{T5_Pgkp1_8 z?Ynz%U#?@o!=lhR9^za}VFmD%@3*Tyu~_Y9c-lFdITp(&tbCebvA3~BEyIKhufrbL2C@zd z(l zhFX7W49b6#dIAzOyf6U#LpRm@%bfEo|35Sa9=?v%3Bmy+5aIb?7oqlqUF0sh8K=4h z8FSvt-4isG+z91Xq8SdHLPE!3hDSsyl=f14yD9~59mBQma}TMuSZw#G3TV&TActa; z2g7of)MsGld!iE3V+`(zN8-!wU*r0y$5u2K5i|T)vvRP+hj1Y7u)JY$R}2I{S zfk&*!-4|fo(wo-|A#zt5odTV ztN@UyGLZeX!!?+I6c?eP$uM|>q3;IpP|)?4y7QNl9TWuZFer=?002CS38>;<=h*M6 zI0x}V6&JIKf55YJ8IUmZw%$w37x<9?7<_;a?f*Uc@|r@oTtUD2*25h5y72QV{5%Ib zL~}y-QOfS6%`?B0h2x`j?3kcqbz}@7POQmKqm-A#fMu^e+4E&49}0;rUGjDomD;U> zi>BvM&MUSw&4=G5zT2k9@iqGr@HC3=T`J6zLn$G~~szf`BQ z7WK73vQ=r4RNpvWcE!raw_vrC_=7Kgk!}4Whu80&T-pT=Rf*)F;@Dk40vLbCZDDBnEj_p z(3?$f%_AS`D|b^{_V3zs`}g2qdqdT0i!G2}An3^&x`B7&vAyr59T!kW^WI>fL+@s= z0*w9-weT;DUNSvso;8kb!0MF1kU3H~xSPQEPT#)1jV@<`SqBA?=UBAKLjpZ{d0>B1 z#P0z&VZaOQclQs*JaY{`O?q+&Y9G+O)&V_c?;; zff)axlx^d?H^V4{yy^2uhtq0`3usqXuik6v$G=u4=37oc9z?=fCZ|+lBdGl0OV6bq z7RvkM;MoyrfOqI-y#HZ8=mqcJcbfo$j8YxdQj28N7}rvYWz>jVDz4Be)}D`)Bh*ok z)KMRN!LF#o(5Ilo!KS3apn84i`T(=Wa~55NJ{4tURydb-gP5ehB&&A~#2=tFpf+&) z5BFbwLHa{We?@x%cL~6I4Zqg?Z-8JNl) zd~=e*wJ$X51TVLCx1&1)rmTt5&3VW5LOs9C+n4&Y^&jL}Yqt19Ce_e*|ZFtJ8 zcJ8bBgPwhgB35PQDE4jC4Sqx0R2zNx>|p}Uz7+YW#Vy%K8PoqyZD#>hW%jjkI;B&( zr5i~J3F+F$t5K#;g}DiRXXNQ=@f9U>ql-AE%K-*v_rE;0X^ar|K2wFH*uxA%MA zd){-;+0Sz}@b&-@8-%Nw`&khk!m_x&6iu`kp_6jbw;)9T8aG!7&(96Z>Dv1Z6!(JeyT$y7rYLoRKP zG*Nip@36|G23WU<%}$xJFBp44YTU(8%eD@u5)FyrSA9$>5lwZ1NlbAEu*K^q;e0R4 zGw+Lig;E2Gb^59pL;+Fkm|!}R=2~n+0FLuRQk3)=jP&q{xCJq;5W3N0qvGuh1v_`q zMCW8G(*muJOrIH`4ZszeEj3idEW-$PszdIt@=Aj}TTi9EHDoE?z=sEQ;+(8cspq4~ z@yL?7hC1065BK$yqeUNT=)x45?Hzy2ZafocRtnXb{>Y*Qwt^seuJE!?0R^|B3TI*7 zjXze7NQ$xwkINW`Cd*LikRvqGr)C-XQg6K&Q&}@cp^&jg;rtb|VQqomw4%Ds^sYkh zHxA?2(Z}UzJU;knU=pL5$V-+(G_Qy|MmrOnJMMS35Mc=Suswjzg4J|{ ziE{HXEJ^fHFN>?I;<-I{Pv3B|nw%9~KW$HN~=ext1EhHVyWE zVSqLv(Zu^#9a0pJ14~QO<7fNph~#W72u^!D&WKHSJMJ7!CQH6)E>&ow7w#a-fkY}X z69wCA4G@5ggu~%_l1#K0RygQ$|CFhvgeG;(bDM$ngZndGk>=PD=05doN~1-V&~?d| z6^X$Gqn@gtS?XIi;TW0ZhMC->p&rB!46`D3r{|QYzHP8ecEFf#d}74&P-|MgKaO>T zTqPZgAL@RGqwc!~aCGd~t<$X;4A}dVpO+lIXw@9CX+3$24Zw#4)F?g@TatCKT^*lddG>sizPh1ZlSkU))BS-HROGSp%;)W+C9?I_vK-xE1~I z(BO62>;2$QGf2iTyHx%eMi4w>lMQ+F59?r#E-adjluN-svLVv)qKCextOo?B z7$^H|yDO9j-yc8cK105keB!csU9$Bv{JVMI_vK5+8;tnK85!xm7q0_nf4`gcUH<8} z5tPxyz}XGB_+t5EE(q!jhyon0qZjDXzCTv%fiH%C7Kp{4%c(!wR8mv~D%uu57u+pZ zp%rJK?d?+B{pAbwbmZ%fcN zeYL7Hy_i_=NLgUmbCk`nP0PgF-6t@I>OE&(2!6nh-|N@SgPwY&YJTS*wQR8C?-H(5 zf2*w>)hbgu2!RbW<=2=>>&}nR(Zbb(YZ6OX>>Y|ar}E6jo59{iV`)&kbC+Apfx@!8 zPCv)}TcX(>p3TS+{KcEsDB|*)SNES?@gH`bdcT`9{MqF{eoc47pZ|R0g7&vPx}Rnw z^Zl0uz#G8{2@H(=Z|T4lSD;NOlhI{Mk&T3DpbrFU`!wV+F*1|fV?L*em~>lsE%k)g zt@2`O{)W#n&@^1EYGjzdO}jo_IC?OMg1Sw$Od7L(DK29T3DA+ngwVbO<~mss>4N20is|v+$eUCkYyFi-s_|b3fa}NB7DWs zdd2cy%trQS}{O9&W`tK?B%^bZn<f2 z4Tx>r{+jw^MhU4=VZS-1pAJ>h0K!AJF933#QBd303_MCn0n-+&m4<@9J{T&*EpUvUIGbou$Y@&x#FU)3cVwJckjUv| zBE6CDrD(_qM)HeaPK1-8p@?hY*xTZLNv(nNKEbGJto-1yaa1#DE4Qgr&~{X|B%L^v zUITknnklA}gB<-ZHCeQ3!y=%-pt$+_1I5yN4UCT$O#e z{5^>-Y)tQ;s8+)`sjZQb!3e$J!cbmd&ZFXLy!{$8VzT>A42ACSBGahg7JpM=7Zulv z1BDpGwp0qD_rhF+drgGa;X`KTQg~~thygW6s5|D8_FkJpfJu`2IT!zdSI5I4yUUu% zx`4r3_76?8My<3t#>X(@+i;hK2U3d1V3Lf;K1633+>TX2Bnz^`VsD!ltjX};c{=7K zX*@C1Mrc{PX7k*#_|pg~s=XwXp?*!}sEmCmet~5*%ZrSS#hugLvHce%Z*jekJzZF! z_M$45Mk#pxNP$5iZ^3W1qTWbh90;Cj$n+0*e6WzB&Be2m zyCQp)-sM*7BbkV3QHFe0Sbaj@sQOh98i8^?2(^t>HWyvM{3ZO?20}6JK*`tDGL$2M zU!}9D#{)7Hvd73HRaB*pox*gzWo+Rq zhAxuKvK^x8EiYU~I^Zh~<>_l?*o1s0ljFaQ1J;*TNT4e`Ti4M1K-k^^Y#IfzE^jEq zPKCG*8Nk8SYj1ojYSHeMDjdB>vb=H$ahsJ5e#p|0KDb*JPZNx+Nh7$OEo}9ML=kdU z(V64!NbPc3F)tM4^fM@yexh>lG6t`dkc@~>VGN4akmRJ~KFPk1ao%E3yq%Wi)KlsU zQc%j7>3B%87`&a52w3>F5NKo)Ay^dNe5m>{l$P-SC4$-T&`IST!i6^Rj58XtHOXg_pN*El4mK0TN-(XX@(^_JNdsvEY+FCU$>oXF|d zX2qP}6+Ps^`w3z-hU9# zLY>Dk?~`$O_|0f`X}?~tB~}U3wL(DuNDrilm9NxK6XyIY_bhPJHJJP#)NA}0x|#l% zk^C_I1D-!;V0CFcPqzMT2BF6kxn*Y**p$YUT!*;c`VoRos&>F6b^s>xqa=>i&@P&Ga93*f16qwN=!+%g;q zz+Wgrcf$hBUSyk^Z)d-Nv5O8{v!Z_M?&7opw{pbC$>$hJl2&IbGrNBF>K>Wfwwgze zQt?|U?&mdP*+jGa+$&CEiqZtTNV3esB-4R+B%*mzDc+^NXB81LQZ$RA5Z6SIn1WF% zv^wZ=!JxO*Cx;8??SE0qO{?l+f8IKL*j?zPNJ+1?y@+0fkOlB{5OsxLDjf*!Qhd9= zPY*+nU8y}@pa*5Q=pgBdsacJxi+(~xS2&yQNm`nIzMtpnesa4>PVeMwGlyxC7&U0o z3tM!XsHpDnYr?zt-iM3AC{1gdI$Jw$5IqCh6ant99OB4{>V|dCf7ifOU(x6fdTXo=xL*INGw?O&>t0of`)q82WBDo@} zMOICfy8EwLcHy@^-eudAtZLmr%pDCWwR}fJujY4@9o=H8;TbOkw`D^b(2;?)Xf7>V z=T*HjQTtR@W2$nFJ|FFYIa!6yZf{w+O6h*e$^(+rc6N+9^U6tIvl1bFlo^Z97N2z) z?Q`1i7rkR}*nr}3#$B~ow^-L@c6l(jX{fcy*!8LLHb2Uym^Ew@z9Cr-pf@3v=X+csoK^ zM`Np%l}{_ipi17Ho3II6YV@hz6DDvA$~~fV2XK>%WQQqj-r0~*?BvW)GlB*!(m{~PtPAfke{cLwG6j3 zwSvvfI6bT&tm;ui+_ThQ)fU7jCg!#69di8q1|Fe49UR85K1W1fo>WCW@9f>#y&y4l zD(V*BEwn(JQFhEbug~uFw|D!8p)w5%QZZ`;xP9&f$w3de$n|M3JWTu)3PyuH-##ecCUqn`G$i z>g=ZsAIdgM7_F4XU+W;-VJe0tB9~j?x%D1~t7vl9$E!Otq}tl7me(LqCH; zUjl80A6*uhXkH!?g-qKDO#;t?_69NAEg*@(s-i3-S%;|Ga}%%Ie<6uqv^nrSXW&D* zH+Rn3qjWXrU-jGga~2nYze7EFyku(Jl-S!6<<%eCj{H?3wIbZNJVKJB`3#IKHMw=V z$s4*Loo$$yELcQP`GG&dPOMn}D7;Q5asefh$EJ&KEmkTtO>}dEH}B`BDQfG!)eal} zEun&#XU7MRbI_Ye(W!^WY$;)EMlqI|P&OtJN`T5Z_s%MY<6_+%YpJO(K+8mjbB#LZ zP64;hX$P+Z$>ha*Yz*Is3>w6x@3$!HOEyYCbJL*6Jjskk!xSsZEl`f5iv@7H68SRt zEE?4$cw$5|VV(_J)-5m#Y(G8e9`BB_p5UZ2S0GJaADppwca-9uj5~atMosqAE{GZv zG13=Po!I^OzGYJBr=74KV_OG6sH(Iq+1Uv^^# zLz?AyXuR_$)x_Zzg*<5I^7GhH%2*4gSyg*4rV}ZYe zySs|gLM~m(*e5A~Ha&epe6h$RTjH&0=P=@S3|!I^0*<;||MG)3=rYrf&)?5uCoF(I z%|Tm-G(jzql{5Ekp=+o`KWi-Om(Hr`N z(xSWP=P9g9mb}a{i&@oJ`=vjc;G&C7&#YT5!^=e5NihuE!w#`54b0Zna*W$t>yU|& zs-?L#%NnT~D8KKe#rQbnQC84I zYbK_7Q6#yQiKh(`GdeQv@Wci#{T3~`O?6}Ko9(-wkm*wh6YbV_N$$J$+oZ)XnuQ^` zAx0z`@fe!kR_rVDKO8bXNf}FralsN^Xz@+?p!Gu9+h;vnoSgri)fiJlW77mp1tF0P zQZBpn@3vk8N~|78+0U94$tLLyk;;;zyFKF9F|a*+{$yR&=1 zqE4#6ysLgp{(nDQ2zbQak9(+4b;4#s4ApB%O}YodJT5w7D8np{gtHdFO2<1P3h7H_t4cAG={<$^7tMUWH*PbwIFz$@tfq(l zZS$*#+qd;&IZ`UysRqJFPr(^qW-L{;p~^MZfV+6`9lW8<^6<^yqdkja>-?OJnQEri zfMcA_yG4dmlu+RSGHbQ)y zcCA??lgW25ur)9Vlix|;%SGu8zKBtRDTr+>SNiB2tt|Fp7QXfcz{DBMQ?DbkP63WX)SmYh4yi89h!{)0 z^?zOiVSr;ZjkTWe^reJJ?+AC+OINVrFE5dUe9VLw&NMkKeR(q4*k$y#$_fCet2y;d zX2X^0uq>f~y#&wT*P)0Mbmi=!T7oOq2eLw?k{kjJ^XzSqU|EhIRM{-ceb<1c_NEPr# z`=2TNxpR6^LUb*U>jtl&2&>!w9s%l~de!a~G`Z_ut)OIly#Gf2qr~tk@vt#YPy##BSDGtzleBave!KzLD3N;KcDPhIznE}{IU}yC?1ydm*Fq_LS7Bw zvWp{V2)+MbA>7y-zgd!8vR?#^B^|h9`;+%Q@c9X9#t54Kcjjd)LQp0=#jj%CnDBK& zK2W$X3hg3S6Q3ufX36he3(I_30&>8Bk(4(@zsG8L(U>UNw2SVEQrt z8sd%pd6UJ;1=^eCr_p~Ju7DKYTlQ{$e_%fpJ!f|2Vccr)**vpZ3KQg)$7Tj#6|46F>8pHR?cU7fw5d|6W*pq*7`TkO~0!q3`opC{m1)d)A4@iHMKK_JO12mSK zv>F$&pez4fEH^7RKnd6D^Do*51M>yi3H|SEFPCXuTQR?0I||you=c-e{*U9MFDgkv zQ@LJa2FiM(|1&I*iZf8u_2LRp)UoluM1kBTpp@&I?VuDnv%jKT+GGN5y~|5M!+igr Q_kiCPz=ivlR^Na6KT%u?`2YX_ literal 0 HcmV?d00001 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.2.tm index 9270ca9c..c7da645b 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.2.tm @@ -185,6 +185,8 @@ namespace eval tomlish { error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" } ITABLE { + #This one should not be returned as a type value structure! + # set result [::tomlish::to_dict [list $found_sub]] } ARRAY { @@ -249,6 +251,7 @@ namespace eval tomlish { } + #to_dict is a *basic* programmatic datastructure for accessing the data. # produce a dictionary of keys and values from a tomlish tagged list. # to_dict is primarily for reading toml data. @@ -271,8 +274,12 @@ namespace eval tomlish { # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. #we don't error out just because a previous tablename segment has already appeared. - variable tablenames_seen [list] - + ##variable tablenames_seen [list] + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] + } log::info ">>> processing '$tomlish'<<<" set items $tomlish @@ -311,9 +318,9 @@ namespace eval tomlish { } DOTTEDKEY { log::debug "--> processing $tag: $item" - set dkey_info [_get_dottedkey_info $item] - set dotted_key_hierarchy [dict get $dkey_info keys] - set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] + set dkey_info [_get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] #a.b.c = 1 #table_key_hierarchy -> a b @@ -345,6 +352,9 @@ namespace eval tomlish { set keyval_dict [_get_keyval_value $item] dict set datastructure {*}$pathkeys $leafkey $keyval_dict + + #JMN test 2025 + } TABLE { set tablename [lindex $item 1] @@ -386,8 +396,40 @@ namespace eval tomlish { lappend table_key_hierarchy_raw $rawseg if {[dict exists $datastructure {*}$table_key_hierarchy]} { - #It's ok for this key to already exist *if* it was defined by a previous tablename, - # but not if it was defined as a key/qkey/skey ? + #It's ok for this key to already exist *if* it was defined by a previous tablename or equivalent + #and if this key is longer + + #consider the following 2 which are legal: + #[table] + #x.y = 3 + #[table.x.z] + #k= 22 + + #equivalent + + #[table] + #[table.x] + #y = 3 + #[table.x.z] + #k=22 + + #illegal + #[table] + #x.y = 3 + #[table.x.y.z] + #k = 22 + ## - we should bfail on encoungerint table.x.y because only table and table.x are effectively tables + ## - we should also fail if + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + + #TODO! fix - this code is wrong set testkey [join $table_key_hierarchy_raw .] @@ -422,7 +464,7 @@ namespace eval tomlish { if {$found_testkey == 0} { #the raw table_key_hierarchy is better to display in the error message, although it's not the actual dict keyset set msg "key [join $table_key_hierarchy_raw .] already exists in datastructure, but wasn't defined by a supertable." - append msg "tablenames_seen:" + append msg \n "tablenames_seen:" \n foreach ts $tablenames_seen { append msg " " $ts \n } @@ -453,13 +495,18 @@ namespace eval tomlish { #now add the contained elements foreach element [lrange $item 2 end] { set type [lindex $element 0] + log::debug "--> $type processing contained element $element" switch -exact -- $type { DOTTEDKEY { set dkey_info [_get_dottedkey_info $element] - set dotted_key_hierarchy [dict get $dkey_info keys] - set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] - set leaf_key [lindex $dotted_key_hierarchy end] - set dkeys [lrange $dotted_key_hierarchy 0 end-1] + #e.g1 keys {x.y y} keys_raw {'x.y' y} + #e.g2 keys {x.y y} keys_raw {{"x.y"} y} + set dotted_key_hierarchy [dict get $dkey_info keys] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + set leaf_key [lindex $dotted_key_hierarchy end] + set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] + set dkeys_raw [lrange $dotted_key_hierarchy_raw 0 end-1] + set leaf_key_raw [lindex $dotted_key_hierarchy_raw end] #ensure empty keys are still represented in the datastructure set test_keys $table_keys @@ -476,7 +523,22 @@ namespace eval tomlish { error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." } set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout ">>> $keyval_dict" dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + #JMN 2025 + #tomlish::utils::normalize_key ?? + lappend tablenames_seen [join [list {*}$table_key_hierarchy_raw {*}$dkeys_raw] .] ;#???? + #if the keyval_dict is not a simple type x value y - then it's an inline table ? + #if so - we should add the path to the leaf_key as a seen table too - as it's not allowed to have more entries added. + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + lappend tablenames_seen [join [list {*}$table_key_hierarchy_raw {*}$dkeys_raw $leaf_key_raw] .] + } + } KEY - QKEY - SQKEY { #obsolete ? @@ -777,7 +839,7 @@ namespace eval tomlish { set result [list] set lastparent [lindex $parents end] if {$lastparent in [list "" do_inline]} { - if {[tomlish::dict::is_tomltype $vinfo]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { set type [dict get $vinfo type] #treat ITABLE differently? set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] @@ -811,7 +873,7 @@ namespace eval tomlish { } else { set VK_PART [list KEY $vk] } - if {[tomlish::dict::is_tomltype $vv]} { + if {[tomlish::dict::is_tomlish_typeval $vv]} { #type x value y set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] @@ -877,7 +939,7 @@ namespace eval tomlish { } } else { #lastparent is not toplevel "" or "do_inline" - if {[tomlish::dict::is_tomltype $vinfo]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { #type x value y set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] lappend result {*}$sublist @@ -901,7 +963,7 @@ namespace eval tomlish { } else { set VK_PART [list KEY $vk] } - if {[tomlish::dict::is_tomltype $vv]} { + if {[tomlish::dict::is_tomlish_typeval $vv]} { #type x value y set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] set record [list DOTTEDKEY [list $VK_PART] = $sublist] @@ -2404,7 +2466,8 @@ namespace eval tomlish::utils { } ;#RS #check if str is valid for use as a toml bare key - proc is_barekey {str} { + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { if {[tcl::string::length $str] == 0} { return 0 } else { @@ -2418,6 +2481,52 @@ namespace eval tomlish::utils { } } + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + #test only that the characters in str are valid for the toml specified type 'integer'. proc int_validchars1 {str} { set numchars [tcl::string::length $str] @@ -3471,7 +3580,7 @@ namespace eval tomlish::parse { return 1 } barekey { - error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z_-\] allowed. [tomlish::parse::report_line]" + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" } whitespace { # hash marks end of whitespace token @@ -5222,7 +5331,7 @@ namespace eval tomlish::parse { if {[tomlish::utils::is_barekey $c]} { append tok $c } else { - error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] allowed. [tomlish::parse::report_line]" + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" } } starttablename - starttablearrayname { @@ -5354,10 +5463,15 @@ namespace eval tomlish::dict { namespace export {[a-z]*}; # Convention: export all lowercase namespace path [namespace parent] - proc is_tomltype {d} { - expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value]} + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} } - proc is_tomltype2 {d} { + proc is_tomlish_typeval2 {d} { upvar ::tomlish::tags tags expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} } @@ -5366,7 +5480,7 @@ namespace eval tomlish::dict { set dictposn [expr {[dict size $d] -1}] foreach k [lreverse [dict keys $d]] { set dval [dict get $d $k] - if {[is_tomltype $dval]} { + if {[is_tomlish_typeval $dval]} { set last_simple $dictposn break } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.3.tm new file mode 100644 index 00000000..3da39427 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.3.tm @@ -0,0 +1,6002 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application tomlish 1.1.3 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin tomlish_module_tomlish 0 1.1.3] +#[copyright "2024"] +#[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] +#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] +#[require tomlish] +#[keywords module parsing toml configuration] +#[description] +#[para] tomlish is an intermediate representation of toml data in a tree structure (tagged lists representing type information) +#[para] The design goals are for tomlish to be whitespace and comment preserving ie byte-for byte preservation during roundtrips from toml to tomlish and back to toml +#[para] The tomlish representation can then be converted to a Tcl dict structure or to other formats such as json, +#[para] although these other formats are generally unlikely to retain whitespace or comments +#[para] The other formats also won't preserve roundtripability e.g \t and a literal tab coming from a toml file will be indistinguishable. +#[para] A further goal is to allow at least a useful subset of in-place editing operations which also preserve whitespace and comments. +#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions +#[para] The API for editing (tomldoc object?) may require explicit setting of type if accessing an existing key +#[para] e.g setting a key that already exists and is a different type (especially if nested structure such as a table or array) +#[para] will need a -type option (-force ?) to force overriding with another type such as an int. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of tomlish +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by tomlish +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::stack +package require logger + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {struct::stack}] + +#limit ourselves to clear, destroy, peek, pop, push, rotate, or size (e.g v 1.3 does not implement 'get') + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish { + namespace export {[a-z]*}; # Convention: export all lowercase + variable types + + #IDEAS: + # since get_toml produces tomlish with whitespace/comments intact: + # tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace + # - setKey (set leaf only to value) how to specify type? -type option? - whole array vs index into arrays and further nested objects? - option for raw toml additions? + # - separate addKey?? + # - deleteKey (delete leaf) + # - deleteTable (delete table - if only has leaves? - option to delete with child tables?) + # - set/add Table? - position in doc based on existing tables/subtables? + + #The tomlish intermediate representation allows things such as sorting the toml document by table name or other re-ordering of tables - + # because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. + #The same goes for the first newline following a keyval e.g x=1 \ny=2\n\n + #The newline is part of the keyval structure so makes reordering easier + #example from_toml "a=1\nb=2\n\n\n" + # 0 = TOMLISH + # 1 = KEY a = {INT 1} {NEWLINE lf} + # 2 = NEWLINE lf + # 3 = KEY b = {INT 2} {NEWLINE lf} + # 4 = NEWLINE lf + # 5 = NEWLINE lf + + + #ARRAY is analogous to a Tcl list + #TABLE is analogous to a Tcl dict + #WS = inline whitespace + #KEY = bare key and value + #DQKEY = double quoted key and value + #SQKEY = single quoted key and value + #ITABLE = inline table (*can* be anonymous table) + # inline table values immediately create a table with the opening brace + # inline tables are fully defined between their braces, as are dotted-key subtables defined within + # No additional subtables or arrays of tables may be defined within an inline table after the ending brace - they must be entirely self-contained + + set tags [list TOMLISH ARRAY TABLE ITABLE ANONTABLE WS NEWLINE COMMENT DOTTEDKEY KEY DQKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME] + #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) + #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) + set min_int -9223372036854775808 ;#-2^63 + set max_int +9223372036854775807 ;#2^63-1 + + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] tomlish '$txt'" + puts stderr $msg + } + logger::initNamespace ::tomlish + foreach lvl [logger::levels] { + interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl + log::logproc $lvl tomlish_log_$lvl + } + + #*** !doctools + #[subsection {Namespace tomlish}] + #[para] Core API functions for tomlish + #[list_begin definitions] + + proc tags {} { + return $::tomlish::tags + } + + #helper function for to_dict + proc _get_keyval_value {keyval_element} { + log::notice ">>> _get_keyval_value from '$keyval_element'<<<" + set found_value 0 + #find the value + # 3 is the earliest index at which the value could occur (depending on whitespace) + set found_sub [list] + if {[lindex $keyval_element 2] ne "="} { + error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured { = } list" + } + + #review + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] ;#list of lists + } + if {[uplevel 1 [list info exists tablenames_closed]]} { + upvar tablenames_closed tablenames_closed + } else { + set tablenames_closed [list] ;#list of lists + } + + foreach sub [lrange $keyval_element 2 end] { + #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey + switch -exact -- [lindex $sub 0] { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - TABLE - ARRAY - ITABLE { + set type [lindex $sub 0] + set value [lindex $sub 1] + set found_sub $sub + incr found_value 1 + } + default {} + } + } + if {!$found_value} { + error "tomlish Failed to find value element in KEY. '$keyval_element'" + } + if {$found_value > 1} { + error "tomlish Found multiple value elements in KEY, expected exactly one. '$keyval_element'" + } + + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + #simple (non-container, no-substitution) datatype + set result [list type $type value $value] + } + STRING - STRINGPART { + set result [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL - LITERALPART { + #REVIEW + set result [list type $type value $value] + } + TABLE { + #invalid? + error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" + } + ITABLE { + #This one should not be returned as a type value structure! + # + set result [::tomlish::to_dict [list $found_sub]] + } + ARRAY { + #we need to recurse to get the corresponding dict for the contained item(s) + #pass in the whole $found_sub - not just the $value! + set prev_tablenames_seen $tablenames_seen + set prev_tablenames_closed $tablenames_closed + set tablenames_seen [list] + set tablenames_closed [list] + set result [list type $type value [::tomlish::to_dict [list $found_sub]]] + set tablenames_seen $prev_tablenames_seen + set tablenames_closed $prev_tablenames_closed + } + MULTISTRING - MULTILITERAL { + #review - mapping these to STRING might make some conversions harder? + #if we keep the MULTI - we know we have to look for newlines for example when converting to json + #without specific types we'd have to check every STRING - and lose info about how best to map chars within it + set result [list type $type value [::tomlish::to_dict [list $found_sub]]] + } + default { + error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" + } + } + return $result + } + + proc _get_dottedkey_info {dottedkeyrecord} { + set key_hierarchy [list] + set key_hierarchy_raw [list] + if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { + error "tomlish _get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" + } + set compoundkeylist [lindex $dottedkeyrecord 1] + set expect_sep 0 + foreach part $compoundkeylist { + set parttag [lindex $part 0] + if {$parttag eq "WS"} { + continue + } + if {$expect_sep} { + if {$parttag ne "DOTSEP"} { + error "DOTTEDKEY missing dot separator between parts. '$dottedkeyrecord'" + } + set expect_sep 0 + } else { + set val [lindex $part 1] + switch -exact -- $parttag { + KEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw $val + } + DQKEY { + lappend key_hierarchy [::tomlish::utils::unescape_string $val] + lappend key_hierarchy_raw \"$val\" + } + SQKEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw "'$val'" + } + default { + error "DOTTED key unexpected part '$parttag' - ensure dot separator is between key parts. '$item'" + } + } + set expect_sep 1 + } + } + return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] + } + + + + #to_dict is a *basic* programmatic datastructure for accessing the data. + # produce a dictionary of keys and values from a tomlish tagged list. + # to_dict is primarily for reading toml data. + #Extraneous (not within quoted sections) whitespace and comments are not preserved in this structure, + # so a roundtrip from toml to this datastructure and back to toml will lose whitespace formatting and comments. + # creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. + #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. + # + + #within an ARRAY, we store a list of items such as plain dicts (possibly empty) and {type value } for simple types + #(ARRAYS can be mixed type) + #This means our dict structure should have only ARRAY and simple types which need to be in {type value } form + #A dict within an array encodeded as a type ITABLE value should also parse - but is the unpreferred form - REVIEW test? + + #Namespacing? + #ie note the difference: + #[Data] + #temp = { cpu = 79.5, case = 72.0} + # versus + #[Data] + #temps = [{cpu = 79.5, case = 72.0}] + proc to_dict {tomlish} { + + #keep track of which tablenames have already been directly defined, + # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' + #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. + #we don't error out just because a previous tablename segment has already appeared. + ##variable tablenames_seen [list] + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] ;#list of lists + } + if {[uplevel 1 [list info exists tablenames_closed]]} { + upvar tablenames_closed tablenames_closed + } else { + set tablenames_closed [list] ;#list of lists + } + + log::info "---> to_dict processing '$tomlish'<<<" + set items $tomlish + + foreach lst $items { + if {[lindex $lst 0] ni $::tomlish::tags} { + error "supplied string does not appear to be toml parsed into a tomlish tagged list. Run tomlish::decode::toml on the raw toml data to produce a tomlish list" + } + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + #ignore TOMLISH tag at beginning + set items [lrange $tomlish 1 end] + } + + set datastructure [dict create] + foreach item $items { + set tag [lindex $item 0] + #puts "...> item:'$item' tag:'$tag'" + switch -exact -- $tag { + KEY - DQKEY - SQKEY { + log::debug "---> to_dict item: processing $tag: $item" + set key [lindex $item 1] + if {$tag eq "DQKEY"} { + set key [::tomlish::utils::unescape_string $key] + } + #!todo - normalize key. (may be quoted/doublequoted) + + if {[dict exists $datastructure $key]} { + error "Duplicate key '$key'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #lassign [_get_keyval_value $item] type val + set keyval_dict [_get_keyval_value $item] + dict set datastructure $key $keyval_dict + } + DOTTEDKEY { + log::debug "---> to_dict item processing $tag: $item" + set dkey_info [_get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + + #a.b.c = 1 + #table_key_hierarchy -> a b + #leafkey -> c + if {[llength $dotted_key_hierarchy] == 0} { + #empty?? probably invalid. review + #This is different to '' = 1 or ''.'' = 1 which have lengths 1 and 2 respectively + error "DOTTED key has no parts - invalid? '$item'" + } elseif {[llength $dotted_key_hierarchy] == 1} { + #dottedkey is only a key - no table component + set table_hierarchy [list] + set leafkey [lindex $dotted_key_hierarchy 0] + } else { + set table_hierarchy [lrange $dotted_key_hierarchy 0 end-1] + set leafkey [lindex $dotted_key_hierarchy end] + } + + #ensure empty tables are still represented in the datastructure + #review - this seems unnecessary? + set pathkeys [list] + foreach k $table_hierarchy { + lappend pathkeys $k + if {![dict exists $datastructure {*}$pathkeys]} { + dict set datastructure {*}$pathkeys [list] + } else { + tomlish::log::notice "to_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" + } + } + #review? + if {[dict exists $datastructure {*}$table_hierarchy $leafkey]} { + error "Duplicate key '$table_hierarchy $leafkey'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #JMN test 2025 + if {[llength $table_hierarchy]} { + lappend tablenames_seen $table_hierarchy + } + + set keyval_dict [_get_keyval_value $item] + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + lappend tablenames_seen [list {*}$table_hierarchy $leafkey] + lappend tablenames_closed [list {*}$table_hierarchy $leafkey] + + #review - item is an ITABLE - we recurse here without datastructure context :/ + #overwriting keys? todo ? + dict set datastructure {*}$table_hierarchy $leafkey $keyval_dict + } else { + dict set datastructure {*}$table_hierarchy $leafkey $keyval_dict + } + + } + TABLE { + set tablename [lindex $item 1] + #set tablename [::tomlish::utils::tablename_trim $tablename] + set norm_segments [::tomlish::utils::tablename_split $tablename true] ;#true to normalize + if {$norm_segments in $tablenames_seen} { + error "Table name '$tablename' has already been directly defined in the toml data. Invalid." + } + + log::debug "---> to_dict processing item $tag (name: $tablename): $item" + set name_segments [::tomlish::utils::tablename_split $tablename] ;#unnormalized + set last_seg "" + #toml spec rule - all segments mst be non-empty + #note that the results of tablename_split are 'raw' - ie some segments may be enclosed in single or double quotes. + + set table_key_sublist [list] + + foreach normseg $norm_segments { + lappend table_key_sublist $normseg + if {[dict exists $datastructure {*}$table_key_sublist]} { + #It's ok for this key to already exist *if* it was defined by a previous tablename or equivalent + #and if this key is longer + + #consider the following 2 which are legal: + #[table] + #x.y = 3 + #[table.x.z] + #k= 22 + + #equivalent + + #[table] + #[table.x] + #y = 3 + #[table.x.z] + #k=22 + + #illegal + #[table] + #x.y = 3 + #[table.x.y.z] + #k = 22 + ## - we should fail on encountering table.x.y because only table and table.x are effectively tables + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + + #note: it is not safe to compare normalized tablenames using join! + # e.g a.'b.c'.d is not the same as a.b.c.d + # instead compare {a b.c d} with {a b c d} + # Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. + #'a.b'.'c.d.e' vs 'a.b.c'.'d.e' + #we need to normalize the tablenames seen so that {"x\ty"} matches {"xy"} + + set sublist_length [llength $table_key_sublist] + set found_testkey 0 + if {$table_key_sublist in $tablenames_seen} { + set found_testkey 1 + } else { + #see if it was defined by a longer entry + foreach seen_table_segments $tablenames_seen { + if {[llength $seen_table_segments] <= $sublist_length} { + continue + } + #each tablenames_seen entry is already a list of normalized segments + + #we could have [a.b.c.d] early on + # followed by [a.b] - which was still defined by the earlier one. + + set seen_longer [lrange $seen_segments 0 [expr {$sublist_length -1}]] + puts stderr "testkey:'$table_key_sublist' vs seen_match:'$seen_longer'" + if {$table_key_sublist eq $seen_longer} { + set found_testkey 1 + } + } + } + + if {$found_testkey == 0} { + #the raw table_key_hierarchy is better to display in the error message, although it's not the actual dict keyset + set msg "key $table_key_sublist already exists in datastructure, but wasn't defined by a supertable." + append msg \n "tablenames_seen:" \n + foreach ts $tablenames_seen { + append msg " " $ts \n + } + error $msg + } + } + + } + + #ensure empty tables are still represented in the datastructure + set table_keys [list] + foreach k $table_key_hierarchy { + lappend table_keys $k + if {![dict exists $datastructure {*}$table_keys]} { + dict set datastructure {*}$table_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (TABLE) subkey $table_keys already had data: [dict get $datastructure {*}$table_keys]" + } + } + + #We must do this after the key-collision test above! + lappend tablenames_seen $norm_segments + + + log::debug ">>> to_dict >>>>>>>>>>>>>>>>> table_key_hierarchy : $table_key_hierarchy" + + #now add the contained elements + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [_get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + set dotted_key_hierarchy [dict get $dkey_info keys] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + set leaf_key [lindex $dotted_key_hierarchy end] + + #ensure empty keys are still represented in the datastructure + set test_keys $table_keys + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { + error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> $keyval_dict" + dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + #JMN 2025 + lappend tablenames_seen [list {*}$table_key_hierarchy {*}$dkeys] + + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + lappend tablenames_seen [list {*}$table_key_hierarchy {*}$dkeys $leaf_key] + #if the keyval_dict is not a simple type x value y - then it's an inline table ? + #if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + } + + } + KEY - DQKEY - SQKEY { + #obsolete ? + set keyval_key [lindex $element 1] + if {$type eq "DQKEY"} { + set keyval_key [::tomlish::utils::unescape_string $keyval_key] + } + if {[dict exists $datastructure {*}$dotted_key_hierarchy $keyval_key]} { + error "Duplicate key '$dotted_key_hierarchy $key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + dict set datastructure {*}$dotted_key_hierarchy $keyval_key $keyval_dict + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in table context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + #now make sure we add an empty value if there were no contained elements! + #!todo. + } + ITABLE { + #SEP??? + set datastructure [list] + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [_get_dottedkey_info $element] + set dotted_key_hierarchy [dict get $dkey_info keys] + set leaf_key [lindex $dotted_key_hierarchy end] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + + #ensure empty keys are still represented in the datastructure + set table_keys [list] ;#We don't know the context - next level up will have to check for key collisions? + set test_keys $table_keys + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { + error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + } + ARRAY { + #arrays in toml are allowed to contain mixtures of types + set datastructure [list] + log::debug "--> processing array: $item" + + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + STRING { + set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + ITABLE { + #anonymous table + #lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + lappend datastructure [::tomlish::to_dict [list $element]] ;#store itables within arrays as raw dicts (possibly empty) + } + TABLE { + #invalid? shouldn't be output from from_dict - but could manually be constructed as such? review + #doesn't make sense as table needs a name? + #take as synonym for ITABLE? + error "to_dict TABLE within array unexpected" + } + ARRAY - MULTISTRING - MULTILITERAL { + #set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + } + WS - SEP - NEWLINE - COMMENT { + #ignore whitespace, commas, newlines and comments + } + default { + error "Unexpected value type '$type' found in array" + } + } + } + } + MULTILITERAL { + #triple squoted string + #first newline stripped only if it is the very first element + #(ie *immediately* following the opening delims) + #All whitespace other than newlines is within LITERALPARTS + # ------------------------------------------------------------------------- + #todo - consider extension to toml to allow indent-aware multiline literals + # how - propose as issue in toml github? Use different delim? e.g ^^^ ? + #e.g + # xxx=?'''abc + # def + # etc + # ''' + # - we would like to trimleft each line to the column following the opening delim + # ------------------------------------------------------------------------- + + log::debug "---> todict processing multiliteral: $item" + set parts [lrange $item 1 end] + if {[lindex $parts 0 0] eq "NEWLINE"} { + set parts [lrange $parts 1 end] ;#skip it + } + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + switch -exact -- $type { + LITERALPART { + append stringvalue [lindex $element 1] + } + NEWLINE { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + MULTISTRING { + #triple dquoted string + log::debug "---> to_dict processing multistring: $item" + set stringvalue "" + set idx 0 + set parts [lrange $item 1 end] + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + #We use STRINGPART in the tomlish representation as a distinct element to STRING - which would imply wrapping quotes to be reinserted + switch -exact -- $type { + STRING { + #todo - do away with STRING ? + #we don't build MULTISTRINGS containing STRING - but should we accept it? + tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" + append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" + } + STRINGPART { + append stringvalue [::tomlish::utils::unescape_string [lindex $element 1]] + } + CONT { + #When the last non-whitespace character on a line is an unescaped backslash, + #it will be trimmed along with all whitespace (including newlines) up to the next non-whitespace character or closing delimiter + # review - we allow some whitespace in stringpart elements - can a stringpart ever be all whitespace? + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + append stringvalue "\\" ;#add the sep + } else { + #skip over ws without emitting + set idx [llength $parts] + } + } else { + set parts_til_nl [lrange $parts 0 $next_nl-1] + set non_ws [lsearch -index 0 -start $idx+1 -not $parts_til_nl WS] + if {$non_ws >= 0} { + append stringvalue "\\" + } else { + #skip over ws on this line + set idx $next_nl + #then have to check each subsequent line until we get to first non-whitespace + set trimming 1 + while {$trimming && $idx < [llength $parts]} { + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + } else { + set idx [llength $parts] + } + set trimming 0 + } else { + set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + set trimming 0 + } else { + set idx $next_nl + #keep trimming + } + } + } + } + } + } + NEWLINE { + #if newline is first element - it is not part of the data of a multistring + if {$idx > 0} { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + } + WS { + append stringvalue [lindex $element 1] + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + WS - COMMENT - NEWLINE { + #ignore + } + default { + error "Unexpected tag '$tag' in Tomlish list '$tomlish'" + } + } + } + return $datastructure + } + + + proc _from_dictval_tomltype {parents tablestack keys typeval} { + set type [dict get $typeval type] + set val [dict get $typeval value] + switch -- $type { + ARRAY { + set subitems [list] + foreach item $val { + lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP + } + if {[lindex $subitems end] eq "SEP"} { + set subitems [lrange $subitems 0 end-1] + } + return [list ARRAY {*}$subitems] + } + ITABLE { + if {$val eq ""} { + return ITABLE + } else { + return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] + } + } + MULTISTRING { + #value is a raw string that isn't encoded as tomlish + #create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format + #We need to convert controls in $val to escape sequences - except for newlines + # + #consider an *option* to reformat for long lines? (perhaps overcomplex - byte equiv - but may fold in ugly places) + #we could use a line-length limit to decide when to put in a "line ending backslash" + #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW + # + #TODO + set tomlpart "x=\"\"\"\\\n" + append tomlpart $val "\"\"\"" + set tomlish [tomlish::decode::toml $tomlpart] + #e.g if val = " etc\nblah" + #TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } + #lindex 1 3 is the MULTISTRING tomlish list + return [lindex $tomlish 1 3] + } + MULTILITERAL { + #MLL string can contain newlines - but still no control chars + #todo - validate + set tomlpart "x='''\n" + append tomlpart $val ''' + set tomlish [tomlish::decode::toml $tomlpart] + return [lindex $tomlish 1 3] + } + LITERAL { + #from v1.0 spec - "Control characters other than tab are not permitted in a literal string" + #(This rules out raw ANSI SGR - which is somewhat restrictive - but perhaps justified for a config format + # as copy-pasting ansi to a config value is probably not always wise, and it's not something that can be + # easily input via a text editor. ANSI can go in Basic strings using the \e escape if that's accepted v1.1?) + #we could choose to change the type to another format here when encountering invalid chars - but that seems + #like too much magic. We elect to error out and require the dict to have valid data for the types it specifies. + if {[string first ' $val] >=0} { + error "_from_dictval_tomltype error: single quote found in LITERAL - cannot encode dict to TOML-VALID TOMLISH" + } + #detect control chars other than tab + #for this we can use rawstring_to_Bstring_with_escaped_controls - even though this isn't a Bstring + #we are just using the map to detect a difference. + set testval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val] + if {$testval ne $val} { + #some escaping would have to be done if this value was destined for a Bstring... + #therefor this string has controls and isn't suitable for a LITERAL according to the specs. + error "_from_dictval_tomltype error: control chars (other than tab) found in LITERAL value - cannot encode dict to TOML-VALID TOMLISH" + } + return [list LITERAL $val] + } + STRING { + return [list STRING [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val]] + } + INT { + if {![::tomlish::utils::is_int $val]} { + error "_from_dictval_tomltype error: bad INT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list INT $val] + } + FLOAT { + if {![::tomlish::utils::is_float $val]} { + error "_from_dictval_tomltype error: bad FLOAT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list FLOAT $val] + } + default { + if {$type ni [::tomlish::tags]} { + error "_from_dictval_tomltype error: Unrecognised typename '$type' in {type value } - cannot encode dict to TOML-VALID TOMLISH" + } + return [list $type $val] + } + } + } + + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + if {[regexp {\s} $k] || [string first . $k] >= 0} {} + if {![::tomlish::utils::is_barekey $k]} { + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + #requires quoting + #we'll use a basic mechanism for now to determine the type of quoting - whether it has any single quotes or not. + #todo - more? + #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) + if {[string first ' $k] >=0} { + #basic string + } else { + #literal string + set K_PART [list SQKEY $k] + } + } else { + set K_PART [list KEY $k] + } + puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" + puts stderr "---tablestack: $tablestack---" + set result [list] + set lastparent [lindex $parents end] + if {$lastparent in [list "" do_inline]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + set type [dict get $vinfo type] + #treat ITABLE differently? + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} + } else { + #set result [list TABLE $k {NEWLINE lf}] + if {$vinfo ne ""} { + + #set result [list DOTTEDKEY [list [list KEY $k]] = ] + #set records [list ITABLE] + + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + + if {$lastparent eq "do_inline"} { + set result [list DOTTEDKEY [list $K_PART] =] + set records [list ITABLE] + } else { + #review - quoted k ?? + set result [list TABLE $k {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $k]] + set records [list] + } + + + + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + dict for {vk vv} $vinfo { + if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + set VK_PART [list SQKEY $vk] + } else { + set VK_PART [list KEY $vk] + } + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] + } else { + if {$vv eq ""} { + #experimental + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" + #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] + set tname [join [list {*}$keys $vk] .] + set record [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + } else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + } + } else { + if { 0 } { + #experiment.. sort of getting there. + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" + set tname [join [list {*}$keys $vk] .] + set record [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + + #review - todo? + set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] + lappend record {*}$dottedkey_value + + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + } + if {$dictidx != $lastidx} { + #lappend record SEP + if {$lastparent eq "do_inline"} { + lappend record SEP + } else { + lappend record {NEWLINE lf} + } + } + lappend records $record + incr dictidx + } + if {$lastparent eq "do_inline"} { + lappend result $records {NEWLINE lf} + } else { + lappend result {*}$records {NEWLINE lf} + } + } else { + if {$lastparent eq "do_inline"} { + lappend result DOTTEDKEY [list [list KEY $k]] = ITABLE {NEWLINE lf} + } else { + lappend result TABLE $k {NEWLINE lf} + } + } + } + } else { + #lastparent is not toplevel "" or "do_inline" + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result {*}$sublist + } else { + if {$lastparent eq "TABLE"} { + #review + dict for {vk vv} $vinfo { + set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] + lappend result [list DOTTEDKEY [list [list KEY $vk]] = $dottedkey_value {NEWLINE lf}] + } + } else { + if {$vinfo ne ""} { + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + set sub [list] + #REVIEW + #set result $lastparent ;#e.g sets ITABLE + set result ITABLE + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + dict for {vk vv} $vinfo { + if {[regexp {\s} $vk] || [string first . $vk] >=0} { + set VK_PART [list SQKEY $vk] + } else { + set VK_PART [list KEY $vk] + } + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART] = $sublist] + } else { + if {$vv eq ""} { + #can't just uninline at this level + #we need a better method to query main dict for uninlinability at each level + # (including what's been inlined already) + #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + # puts stderr "_from_dictval uninline2 KEY $keys" + # set tname [join [list {*}$keys $vk] .] + # set record [list TABLE $tname {NEWLINE lf}] + # set tablestack [list {*}$tablestack [list T $vk]] + #} else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + #} + } else { + #set sub [_from_dictval ITABLE $vk $vv] + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + #set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + if {$dictidx != $lastidx} { + lappend record SEP + } + lappend result $record + incr dictidx + } + } else { + puts stderr "table x-1" + lappend result DOTTEDKEY [list $K_PART] = ITABLE + } + } + } + } + return $result + } + + + proc from_dict {d} { + #consider: + # t1={a=1,b=2} + # x = 1 + #If we represent t1 as an expanded table we get + # [t1] + # a=1 + # b=2 + # x=1 + # --- which is incorrect - as x was a toplevel key like t1! + #This issue doesn't occur if x is itself an inline table + # t1={a=1,b=2} + # x= {no="problem"} + # + # (or if we were to reorder x to come before t1) + + #As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} + #Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, + #which is unpreferred here. + + #A possible solution: + #scan the top level to see if all (trailing) elements are themselves dicts + # (ie not of form {type XXX value yyy}) + # + # A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements + #ie we don't need to force do_inline if all the 'simple' keys are before any compound keys + + #set root_has_values 0 + #approach 1) - the naive approach - forces inline when not always necessary + #dict for {k v} $d { + # if {[llength $v] == 4 && [lindex $v 0] eq "type"} { + # set root_has_values 1 + # break + # } + #} + + + #approach 2) - track the position of last {type x value y} in the dictionary built by to_dict + # - still not perfect. Inlines dotted tables unnecessarily + #This means from_dict doesn't produce output optimal for human editing. + set last_simple [tomlish::dict::last_tomltype_posn $d] + + + ## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values + #Any keys that are themselves tables - will need to be represented inline + #to avoid reordering, or incorrect assignment of plain values to the wrong table. + + ## set parent "" + #all toplevel keys in the dict structure can represent subtables. + #we are free to use {[tablename]\n} syntax for toplevel elements. + + + set tomlish [list TOMLISH] + set dictposn 0 + set tablestack [list [list T root]] ;#todo + dict for {t tinfo} $d { + if {$last_simple > $dictposn} { + set parents [list do_inline] + } else { + set parents [list ""] + } + set keys [list $t] + set trecord [_from_dictval $parents $tablestack $keys $tinfo] + lappend tomlish $trecord + incr dictposn + } + return $tomlish + } + + proc json_to_toml {json} { + #*** !doctools + #[call [fun json_to_toml] [arg json]] + #[para] + + set tomlish [::tomlish::from_json $json] + set toml [::tomlish::to_toml $tomlish] + } + + #TODO use huddle? + proc from_json {json} { + #set jstruct [::tomlish::json_struct $json] + #return [::tomlish::from_json_struct $jstruct] + package require huddle + package require huddle::json + set h [huddle::json::json2huddle parse $json] + + } + + proc from_json_struct {jstruct} { + package require fish::json_toml + return [fish::json_toml::jsonstruct2tomlish $jstruct] + } + + proc toml_to_json {toml} { + set tomlish [::tomlish::from_toml $toml] + return [::tomlish::get_json $tomlish] + } + + proc get_json {tomlish} { + package require fish::json + set d [::tomlish::to_dict $tomlish] + #return [::tomlish::dict_to_json $d] + return [fish::json::from "struct" $d] + } + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +namespace eval tomlish::build { + #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness + # take a value of the appropriate type and wrap as a tomlish tagged item + proc STRING {s} { + return [list STRING [::tomlish::utils::rawstring_to_Bstring_with_escaped_controls $s]] + } + proc LITERAL {litstring} { + + } + + proc INT {i} { + #whole numbers, may be prefixed with a + or - + #Leading zeros are not allowed + #Hex,octal binary forms are allowed (toml 1.0) + #We will error out on encountering commas, as commas are interpreted differently depending on locale (and don't seem to be supported in the toml spec anyway) + #!todo - Tcl can handle bignums - bigger than a 64bit signed long as specified in toml. + # - We should probably raise an error for number larger than this and suggest the user supply it as a string? + if {[tcl::string::last , $i] > -1} { + error "Unable to interpret '$i' as an integer. Use underscores if you need a thousands separator [::tomlish::parse::report_line]" + } + if {![::tomlish::utils::int_validchars $i]} { + error "Unable to interpret '$i' as an integer. Only 0-9 + 1 _ characters are acceptable. [::tomlish::parse::report_line]" + } + + if {[::tomlish::utils::is_int $i]} { + return [list INT $i] + } else { + error "'$i' is not a valid integer as per the Toml spec. [::tomlish::parse::report_line]" + } + + } + + proc FLOAT {f} { + #convert any non-lower case variants of special values to lowercase for Toml + if {[::tcl::string::tolower $f] in {nan +nan -nan inf +inf -inf}} { + return [list FLOAT [tcl::string::tolower $f]] + } + if {[::tomlish::utils::is_float $f]} { + return [list FLOAT $f] + } else { + error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" + } + } + + proc DATETIME {str} { + if {[::tomlish::utils::is_datetime $str]} { + return [list DATETIME $str] + } else { + error "Unable to interpret '$str' as Toml datetime. Check your input, or check that tomlish is able to handle all Toml datetimes properly [::tomlish::parse::report_line]" + } + } + + proc BOOLEAN {b} { + #convert any Tcl-acceptable boolean to boolean as accepted by toml - lower case true/false + if {![tcl::string::is boolean -strict $b]} { + error "Unable to convert '$b' to Toml boolean true|false. [::tomlish::parse::report_line]" + } else { + if {$b && 1} { + return [::list BOOL true] + } else { + return [::list BOOL false] + } + } + } + + #REVIEW + #Take tablename followed by + # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} + # (accept also key value {STRING }) + # b) simple 2-element tcl lists being name & *simple* value pairs for which basic heuristics will be used to determine types + proc _table {name args} { + set pairs [list] + foreach t $args { + if {[llength $t] == 4} { + if {[tcl::string::tolower [lindex $t 0]] ne "key" || [tcl::string::tolower [lindex $t 2]] ni "= value"} { + error "Only items tagged as KEY = currently accepted as name-value pairs for table command" + } + lassign $t _k keystr _eq valuepart + if {[llength $valuepart] != 2} { + error "supplied value must be typed. e.g {INT 1} or {STRING test}" + } + lappend pairs [list KEY $keystr = $valuepart] + } elseif {[llength $t] == 2} { + #!todo - type heuristics + lassign $t n v + lappend pairs [list KEY $n = [list STRING $v]] + } else { + error "'KEY = { toml but + # the first newline is not part of the data. + # we elect instead to maintain a basic LITERALPART that must not contain newlines.. + # and to compose MULTILITERAL of multiple NEWLINE LITERALPART parts, + #with the datastructure representation dropping the first newline (if immediately following opening delim) when building the value. + set literal "" + foreach part [lrange $item 1 end] { + append literal [::tomlish::encode::tomlish [list $part] $nextcontext] + } + append toml '''$literal''' + } + INT - + BOOL - + FLOAT - + DATETIME { + append toml [lindex $item 1] + } + INCOMPLETE { + error "cannot process tomlish term tagged as INCOMPLETE" + } + COMMENT { + append toml "#[lindex $item 1]" + } + BOM { + #Byte Order Mark may appear at beginning of a file. Needs to be preserved. + append toml "\uFEFF" + } + default { + error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command." + } + } + + } + return $toml + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::encode ---}] +} +#fish toml from tomlish + +#(encode tomlish as toml) +interp alias {} tomlish::to_toml {} tomlish::encode::tomlish + +# + + +namespace eval tomlish::decode { + #*** !doctools + #[subsection {Namespace tomlish::decode}] + #[para] + #[list_begin definitions] + + #return a Tcl list of tomlish tokens + #i.e get a standard list of all the toml terms in string $s + #where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. + #(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) + # ---------------------------------------------------------------------------------------------- + # NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! + # e.g we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- + #Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. + # (e.g perhaps a toml editor to highlight violations for fixing) + # A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. + # e.g dicts or an object oriented structure + #Note also - *no* escapes in quoted strings are processed. This is up to the datastructure stage + #e.g to_dict will substitute \r \n \uHHHH \UHHHHHHH etc + #This is important for tomlish to maintain the ability to perform competely lossless round-trips from toml to tomlish and back to toml. + # (which is handy for testing as well as editing some part of the structure with absolutely no effect on other parts of the document) + #If we were to unescape a tab character for example + # - we have no way of knowing if it was originally specified as \t \u0009 or \U00000009 or directly as a tab character. + # For this reason, we also do absolutely no line-ending transformations based on platform. + # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + + proc toml {args} { + #*** !doctools + #[call [fun toml] [arg arg...]] + #[para] return a Tcl list of tomlish tokens + + set s [join $args \n] + + namespace upvar ::tomlish::parse is_parsing is_parsing + set is_parsing 1 + + if {[info command ::tomlish::parse::spacestack] eq "::tomlish::parse::spacestack"} { + tomlish::parse::spacestack destroy + } + struct::stack ::tomlish::parse::spacestack + + namespace upvar ::tomlish::parse last_space_action last_space_action + namespace upvar ::tomlish::parse last_space_type last_space_type + + namespace upvar ::tomlish::parse tok tok + set tok "" + + namespace upvar ::tomlish::parse type type + namespace upvar ::tomlish::parse tokenType tokenType + ::tomlish::parse::set_tokenType "" + namespace upvar ::tomlish::parse tokenType_list tokenType_list + set tokenType [list] ;#Flat (un-nested) list of tokentypes found + + namespace upvar ::tomlish::parse lastChar lastChar + set lastChar "" + + + set result "" + namespace upvar ::tomlish::parse nest nest + set nest 0 + + namespace upvar ::tomlish::parse v v ;#array keyed on nest level + + + set v(0) {TOMLISH} + array set s0 [list] ;#whitespace data to go in {SPACE {}} element. + set parentlevel 0 + + namespace upvar ::tomlish::parse i i + set i 0 + + namespace upvar ::tomlish::parse state state + + namespace upvar ::tomlish::parse braceCount braceCount + set barceCount 0 + namespace upvar ::tomlish::parse bracketCount bracketCount + set bracketCount 0 + + set sep 0 + set r 1 + namespace upvar ::tomlish::parse token_waiting token_waiting + set token_waiting [dict create] ;#if ::tok finds a *complete* second token during a run, it will put the 2nd one here to be returned by the next call. + + + set state "table-space" + ::tomlish::parse::spacestack push {type space state table-space} + namespace upvar ::tomlish::parse linenum linenum;#'line number' of input data. (incremented for each literal linefeed - but not escaped ones in data) + set linenum 1 + + set ::tomlish::parse::state_list [list] + try { + while {$r} { + set r [::tomlish::parse::tok $s] + #puts stdout "got tok: '$tok' while parsing string '$s' " + set next_tokenType_known 0 ;#whether we begin a new token here based on what terminated the token result of 'tok' + + + #puts "got token: '$tok' tokenType='$tokenType'. while v($nest) = [set v($nest)]" + #puts "-->tok: $tok tokenType='$tokenType'" + set prevstate $state + set transition_info [::tomlish::parse::goNextState $tokenType $tok $state] + #review goNextState could perform more than one space_action + set space_action [dict get $transition_info space_action] + set newstate [dict get $transition_info newstate] ;#use of 'newstate' vs 'state' makes code clearer below + + if {[tcl::string::match "err-*" $state]} { + ::tomlish::log::warn "---- State error in state $prevstate for tokenType: $tokenType token value: $tok. $state aborting parse. [tomlish::parse::report_line]" + lappend v(0) [list ERROR tokentype $tokenType state $prevstate to $state leveldata [set v($nest)]] + return $v(0) + } + # --------------------------------------------------------- + #NOTE there may already be a token_waiting at this point + #set_token_waiting can raise an error here, + # in which case the space_action branch needs to be rewritten to handle the existing token_waiting + # --------------------------------------------------------- + + if {$space_action eq "pop"} { + #pop_trigger_tokens: newline tablename endarray endinlinetable + #note a token is a pop trigger depending on context. e.g first newline during keyval is a pop trigger. + set parentlevel [expr {$nest -1}] + set do_append_to_parent 1 ;#most tokens will leave this alone - but some like squote_seq need to do their own append + switch -exact -- $tokenType { + squote_seq { + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the xxx-squote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + switch -- $tok { + ' { + tomlish::parse::set_token_waiting type startsquote value $tok complete 1 startindex [expr {$i -1}] + } + '' { + #review - we should perhaps return double_squote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_squote value "" complete 1 startindex [expr {$i - 2}] + } + ''' { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 3}] + } + '''' { + switch -exact -- $prevstate { + leading-squote-space { + error "---- 4 squotes from leading-squote-space - shouldn't get here" + #we should have emitted the triple and left the last for next loop + } + trailing-squote-space { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left squote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]'" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "'"] + } + default { + error "--- don't know how to integrate extra trailing squote with data $v($parentlevel)" + } + } + } + default { + error "--- unexpected popped due to squote_seq but came from state '$prevstate' should have been leading-squote-space or trailing-squote-space" + } + } + } + ''''' { + switch -exact -- $prevstate { + leading-squote-space { + error "---- 5 squotes from leading-squote-space - shouldn't get here" + #we should have emitted the triple and left the following squotes for next loop + } + trailing-squote-space { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 squotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]''" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [LITERALPART "''"] + } + default { + error "--- don't know how to integrate extra trailing 2 squotes with data $v($parentlevel)" + } + } + } + default { + error "--- unexpected popped due to squote_seq but came from state '$prevstate' should have been leading-squote-space or trailing-squote-space" + } + } + } + } + puts stderr "tomlish::decode::toml ---- HERE squote_seq pop <$tok>" + } + triple_squote { + #presumably popping multiliteral-space + ::tomlish::log::debug "---- triple_squote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTILITERAL { + lappend merged $part + } + LITERALPART { + if {$lasttype eq "LITERALPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_squote unhandled part type [lindex $part 0] unable to merge leveldata: $v($next)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + equal { + #pop caused by = + switch -exact -- $prevstate { + dottedkey-space { + tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + dottedkey-space-tail { + #experiment? + tomlish::log::debug "---- equal ending dottedkey-space-tail for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + } + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + tablename { + #note: a tablename only 'pops' if we are greater than zero + error "---- tablename pop should already have been handled as special case zeropoppushspace in goNextState" + } + tablearrayname { + #!review - tablearrayname different to tablename regarding push/pop? + #note: a tablename only 'pops' if we are greater than zero + error "---- tablearrayname pop should already have been handled as special case zeropoppushspace in goNextState" + } + endarray { + #nothing to do here. + } + comma { + #comma for inline table will pop the keyvalue space + lappend v($nest) "SEP" + } + endinlinetable { + ::tomlish::log::debug "---- endinlinetable for last_space_action pop" + } + endmultiquote { + ::tomlish::log::debug "---- endmultiquote for last_space_action 'pop'" + } + default { + error "---- unexpected tokenType '$tokenType' for last_space_action 'pop'" + } + } + if {$do_append_to_parent} { + #e.g squote_seq does it's own appends as necessary - so won't get here + lappend v($parentlevel) [set v($nest)] + } + + incr nest -1 + + } elseif {$last_space_action eq "push"} { + set prevnest $nest + incr nest 1 + set v($nest) [list] + # push_trigger_tokens: barekey dquotedkey startinlinetable startarray tablename tablearrayname + + + switch -exact -- $tokenType { + squote_seq_begin { + #### + if {[dict exists $transition_info starttok] && [dict get $transition_info starttok] ne ""} { + lassign [dict get $transition_info starttok] starttok_type starttok_val + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType $starttok_type + set tok $starttok_val + } + } + squotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + dquotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + XXXdquotedkey - XXXitablequotedkey { + #todo + set v($nest) [list DQKEY $tok] ;#$tok is the keyname + } + barekey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + set waiting [tomlish::parse::get_token_waiting] + if {[llength $waiting]} { + set i [dict get $waiting startindex] + tomlish::parse::clear_token_waiting + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } else { + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + } + startsquote { + #JMN + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + tablename { + #note: we do not use the output of tomlish::tablename_trim to produce a tablename for storage in the tomlish list! + #The tomlish list is intended to preserve all whitespace (and comments) - so a roundtrip from toml file to tomlish + # back to toml file will be identical. + #It is up to the datastructure stage to normalize and interpret tomlish for programmatic access. + # we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, + # so we can raise an error at this point rather than create a tomlish list with obviously invalid table names. + + #todo - review! It's arguable that we should not do any validation here, and just store even incorrect raw tablenames, + # so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the + # tomlish list? + + set test_only [::tomlish::utils::tablename_trim $tok] + ::tomlish::log::debug "---- trimmed (but not normalized) tablename: '$test_only'" + set v($nest) [list TABLE $tok] ;#$tok is the *raw* table name + #note also that equivalent tablenames may have different toml representations even after being trimmed! + #e.g ["x\t\t"] & ["x "] (tab escapes vs literals) + #These will show as above in the tomlish list, but should normalize to the same tablename when used as keys by the datastructure stage. + } + tablearrayname { + set test_only [::tomlish::utils::tablename_trim $tok] + puts stdout "trimmed (but not normalized) tablearrayname: '$test_only'" + set v($nest) [list TABLEARRAY $tok] ;#$tok is the *raw* tablearray name + } + startarray { + set v($nest) [list ARRAY] ;#$tok is just the opening bracket - don't output. + } + startinlinetable { + set v($nest) [list ITABLE] ;#$tok is just the opening curly brace - don't output. + } + startmultiquote { + ::tomlish::log::debug "---- push trigger tokenType startmultiquote" + set v($nest) [list MULTISTRING] ;#container for STRINGPART, WS, CONT, NEWLINE + } + triple_squote { + ::tomlish::log::debug "---- push trigger tokenType triple_squote" + set v($nest) [list MULTILITERAL] ;#container for NEWLINE,LITERAL + } + default { + error "---- push trigger tokenType '$tokenType' not yet implemented" + } + } + + } else { + #no space level change + switch -exact -- $tokenType { + squotedkey { + puts "---- squotedkey in state $prevstate (no space level change)" + lappend v($nest) [list SQKEY $tok] + } + dquotedkey { + puts "---- dquotedkey in state $prevstate (no space level change)" + lappend v($nest) [list DQKEY $tok] + } + barekey { + lappend v($nest) [list KEY $tok] + } + dotsep { + lappend v($nest) [list DOTSEP] + } + starttablename { + #$tok is triggered by the opening bracket and sends nothing to output + } + starttablearrayname { + #$tok is triggered by the double opening brackets and sends nothing to output + } + tablename - tablenamearray { + error "---- did not expect 'tablename/tablearrayname' without space level change (no space level change)" + #set v($nest) [list TABLE $tok] + } + endtablename - endtablearrayname { + #no output into the tomlish list for this token + } + startinlinetable { + puts stderr "---- decode::toml error. did not expect startinlinetable without space level change (no space level change)" + } + startquote { + switch -exact -- $newstate { + string-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "string" + set tok "" + } + quoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "dquotedkey" + set tok "" + } + XXXitable-quoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "itablequotedkey" + set tok "" + } + default { + error "---- startquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + startsquote { + switch -exact -- $newstate { + literal-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "literal" + set tok "" + } + squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + XXXitable-squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "itablesquotedkey" + set tok "" + } + multiliteral-space { + #false alarm squote returned from squote_seq pop + ::tomlish::log::debug "---- adding lone squote to own LITERALPART nextstate: $newstate (no space level change)" + #(single squote - not terminating space) + lappend v($nest) [list LITERALPART '] + #may need to be joined on pop if there are neighbouring LITERALPARTs + } + default { + error "---- startsquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + startmultiquote { + #review + puts stderr "---- got startmultiquote in state $prevstate (no space level change)" + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "stringpart" + set tok "" + } + endquote { + #nothing to do? + set tok "" + } + endsquote { + set tok "" + } + endmultiquote { + #JMN!! + set tok "" + } + string { + lappend v($nest) [list STRING $tok] ;#directly wrapped in dquotes + } + literal { + lappend v($nest) [list LITERAL $tok] ;#directly wrapped in squotes + } + double_squote { + switch -exact -- $prevstate { + keyval-value-expected { + lappend v($nest) [list LITERAL ""] + } + multiliteral-space { + #multiliteral-space to multiliteral-space + lappend v($nest) [list LITERALPART ''] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + multistring { + #review + lappend v($nest) [list MULTISTRING $tok] + } + stringpart { + lappend v($nest) [list STRINGPART $tok] ;#will not get wrapped in dquotes directly + } + multiliteral { + lappend v($nest) [LIST MULTILITERAL $tok] + } + literalpart { + lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly + } + itablequotedkey { + + } + untyped_value { + #we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. + if {$tok in {true false}} { + set tag BOOL + } elseif {[::tomlish::utils::is_int $tok]} { + set tag INT + } elseif {[::tomlish::utils::is_float $tok]} { + set tag FLOAT + } elseif {[::tomlish::utils::is_datetime $tok]} { + set tag DATETIME + } else { + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + } + lappend v($nest) [list $tag $tok] + + } + comment { + #puts stdout "----- comment token returned '$tok'------" + lappend v($nest) [list COMMENT "$tok"] + } + equal { + #we append '=' to the nest so that any surrounding whitespace is retained. + lappend v($nest) = + } + comma { + lappend v($nest) SEP + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + whitespace { + lappend v($nest) [list WS $tok] + } + continuation { + lappend v($nest) CONT + } + bom { + lappend v($nest) BOM + } + eof { + #ok - nothing more to add to the tomlish list. + #!todo - check previous tokens are complete/valid? + } + default { + error "--- unknown tokenType '$tokenType' during state $prevstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + + if {!$next_tokenType_known} { + ::tomlish::log::notice "---- tomlish::decode::toml - current tokenType:$tokenType Next token type not known" + ::tomlish::parse::set_tokenType "" + set tok "" + } + + if {$state eq "end-state"} { + break + } + + + } + + #while {$nest > 0} { + # lappend v([expr {$nest -1}]) [set v($nest)] + # incr nest -1 + #} + while {[::tomlish::parse::spacestack size] > 1} { + ::tomlish::parse::spacestack pop + lappend v([expr {$nest -1}]) [set v($nest)] + incr nest -1 + + #set parent [spacestack peek] ;#the level being appended to + #lassign $parent type state + #if {$type eq "space"} { + # + #} elseif {$type eq "buffer"} { + # lappend v([expr {$nest -1}]) {*}[set v($nest)] + #} else { + # error "invalid spacestack item: $parent" + #} + } + + } finally { + set is_parsing 0 + } + return $v(0) + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::decode ---}] +} +#decode toml to tomlish +interp alias {} tomlish::from_toml {} tomlish::decode::toml + +namespace eval tomlish::utils { + #*** !doctools + #[subsection {Namespace tomlish::utils}] + #[para] + #[list_begin definitions] + + + #tablenames (& tablearraynames) may contain irrelevant leading, trailing and interspersed whitespace + # tablenames can be made up of segments delimited by dots. .eg [ a.b . c ] + #trimmed, the tablename becomes {a.b.c} + # A segment may contain whitespace if it is quoted e.g [a . b . "c etc " ] + #ie whitespace is only irrelevant if it's outside a quoted segment + #trimmed, the tablename becomes {a.b."c etc "} + proc tablename_trim {tablename} { + set segments [tablename_split $tablename false] + set trimmed_segments [list] + foreach seg $segments { + lappend trimmed_segments [::string trim $seg " \t"] + } + return [join $trimmed_segments .] + } + + #basic generic quote matching for single and double quotes + #note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes + proc tok_in_quotedpart {tok} { + set sLen [tcl::string::length $tok] + set quote_type "" + set had_slash 0 + for {set i 0} {$i < $sLen} {incr i} { + set c [tcl::string::index $tok $i] + if {$quote_type eq ""} { + if {$had_slash} { + #don't enter quote mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + set quote_type dq + } + sq { + set quote_type sq + } + bsl { + set had_slash 1 + } + } + } + } else { + if {$had_slash} { + #don't leave quoted mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + if {$quote_type eq "dq"} { + set quote_type "" + } + } + sq { + if {$quote_type eq "sq"} { + set quote_type "" + } + } + bsl { + set had_slash 1 + } + } + } + } + } + return $quote_type ;#dq | sq + } + + #utils::tablename_split + proc tablename_split {tablename {normalize false}} { + #we can't just split on . because we have to handle quoted segments which may contain a dot. + #eg {dog."tater.man"} + set sLen [tcl::string::length $tablename] + set segments [list] + set mode "unknown" ;#5 modes: unknown, quoted,litquoted, unquoted, syntax + #quoted is for double-quotes, litquoted is for single-quotes (string literal) + set seg "" + for {set i 0} {$i < $sLen} {incr i} { + + if {$i > 0} { + set lastChar [tcl::string::index $tablename [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $tablename $i] + + if {$c eq "."} { + switch -exact -- $mode { + unquoted { + #dot marks end of segment. + lappend segments $seg + set seg "" + set mode "unknown" + } + quoted { + append seg $c + } + unknown { + lappend segments $seg + set seg "" + } + litquoted { + append seg $c + } + default { + #mode: syntax + #we got our dot. - the syntax mode is now satisfied. + set mode "unknown" + } + } + } elseif {($c eq "\"") && ($lastChar ne "\\")} { + if {$mode eq "unknown"} { + if {[tcl::string::trim $seg] ne ""} { + #we don't allow a quote in the middle of a bare key + error "tablename_split. character '\"' invalid at this point in tablename. tablename: '$tablename'" + } + set mode "quoted" + set seg "\"" + } elseif {$mode eq "unquoted"} { + append seg $c + } elseif {$mode eq "quoted"} { + append seg $c + + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + } else { + lappend segments $seg + } + + set seg "" + set mode "syntax" ;#make sure we only accept a dot or end-of-data now. + } elseif {$mode eq "litquoted"} { + append seg $c + } elseif {$mode eq "syntax"} { + error "tablename_split. expected whitespace or dot, got double quote. tablename: '$tablename'" + } + } elseif {($c eq "\'")} { + if {$mode eq "unknown"} { + append seg $c + set mode "litquoted" + } elseif {$mode eq "unquoted"} { + #single quote inside e.g o'neill + append seg $c + } elseif {$mode eq "quoted"} { + append seg $c + + } elseif {$mode eq "litquoted"} { + append seg $c + #no normalization to do + lappend segments $seg + set seg "" + set mode "syntax" + } elseif {$mode eq "syntax"} { + error "tablename_split. expected whitespace or dot, got single quote. tablename: '$tablename'" + } + + } elseif {$c in [list " " \t]} { + if {$mode eq "syntax"} { + #ignore + } else { + append seg $c + } + } else { + if {$mode eq "syntax"} { + error "tablename_split. Expected a dot separator. got '$c'. tablename: '$tablename'" + } + if {$mode eq "unknown"} { + set mode "unquoted" + } + append seg $c + } + if {$i == $sLen-1} { + #end of data + ::tomlish::log::debug "End of data: mode='$mode'" + #REVIEW - we can only end up in unquoted or syntax here? are other branches reachable? + switch -exact -- $mode { + quoted { + if {$c ne "\""} { + error "tablename_split. missing closing double-quote in a segment. tablename: '$tablename'" + } + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + #lappend segments [subst -nocommands -novariables [::string range $seg 1 end-1]] ;#wrong + } else { + lappend segments $seg + } + } + litquoted { + set trimmed_seg [tcl::string::trim $seg] + if {[tcl::string::index $trimmed_seg end] ne "\'"} { + error "tablename_split. missing closing single-quote in a segment. tablename: '$tablename'" + } + lappend segments $seg + } + unquoted - unknown { + lappend segments $seg + } + syntax { + #ok - segment already lappended + } + default { + lappend segments $seg + } + } + } + } + foreach seg $segments { + set trimmed [tcl::string::trim $seg " \t"] + #note - we explicitly allow 'empty' quoted strings '' & "" + # (these are 'discouraged' but valid toml keys) + #if {$trimmed in [list "''" "\"\""]} { + # puts stderr "tablename_split. warning - Empty quoted string as tablename segment" + #} + if {$trimmed eq "" } { + error "tablename_split. Empty segment found. tablename: '$tablename' segments [llength $segments] ($segments)" + } + } + return $segments + } + + proc unicode_escape_info {slashu} { + #!todo + # validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and + # is a valid 'unicode scalar value' (any Unicode code point except high-surrogate and low-surrogate code points) + # ie integers in the range 0 to D7FF16 and E00016 to 10FFFF16 inclusive + #expr {(($x >= 0) && ($x <= 0xD7FF16)) || (($x >= 0xE00016) && ($x <= 0x10FFFF16))} + if {[tcl::string::match {\\u*} $slashu]} { + set exp {^\\u([0-9a-fA-F]{4}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %4x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } + } else { + return [list err [list reason "Supplied string not of the form \\uHHHH where H in \[0-9a-fA-F\]"]] + } + } elseif {[tcl::string::match {\\U*} $slashu]} { + set exp {^\\U([0-9a-fA-F]{8}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %8x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + if {(($dec >= 0) && ($dec <= 0xD7FF16)) || (($dec >= 0xE00016) && ($dec <= 0x10FFFF16))} { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } else { + return [list err [list reason "$slashu is not within the 'unicode scalar value' ranges 0 to 0xD7FF16 or 0xE00016 to 0x10FFFF16"]] + } + } + } else { + return [list err [list reason "Supplied string not of the form \\UHHHHHHHH where H in \[0-9a-fA-F\]"]] + } + } else { + return [list err [list reason "Supplied string did not start with \\u or \\U" ]] + } + + } + + #Note that unicode characters don't *have* to be escaped. + #So if we provide a function named 'escape_string', the name implies the inverse of unescape_string which unescapes unicode \u \U values. + #- an inverse of unescape_string would encode all unicode chars unnecessarily. + #- as toml accepts a compact escape sequence for common chars such as tab,backspace,linefeed etc but also allows the full form \u009 etc + #- escape_string and unescape_string would not be reliably roundtrippable inverses anyway. + #REVIEW - provide it anyway? When would it be desirable to use? + + variable Bstring_control_map [list\ + \b {\b}\ + \n {\n}\ + \r {\r}\ + \" {\"}\ + \x1b {\e}\ + \\ "\\\\"\ + ] + #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ + #for a Bstring (Basic string) tab is explicitly mentioned as not being one that must be escaped. + for {set cdec 0} {$cdec <= 8} {incr cdec} { + set hhhh [format %.4X $cdec] + lappend Bstring_control_map [format %c $cdec] \\u$hhhh + } + for {set cdec [expr {0x0A}]} {$cdec <= 0x1F} {incr cdec} { + set hhhh [format %.4X $cdec] + lappend Bstring_control_map [format %c $cdec] \\u$hhhh + } + # \u007F = 127 + lappend Bstring_control_map [format %c 127] \\u007F + + #Note the inclusion of backslash in the list of controls makes this non idempotent - subsequent runs would keep encoding the backslashes! + #escape only those chars that must be escaped in a Bstring (e.g not tab which can be literal or escaped) + #for example - can be used by from_dict to produce valid Bstring data for a tomlish record + proc rawstring_to_Bstring_with_escaped_controls {str} { + #for the well known chars that have compact escape sequences allowed by toml - we choose that form over the full \u form. + #we'll use a string map with an explicit list rather than algorithmic at runtime + # - the string map is probably more performant than splitting a string, especially if it's large + variable Bstring_control_map + return [string map $Bstring_control_map $str] + } + + #review - unescape what string? Bstring vs MLBstring? + #we should be specific in the function naming here + #used by to_dict - so part of validation? - REVIEW + proc unescape_string {str} { + #note we can't just use Tcl subst because: + # it also transforms \a (audible bell) and \v (vertical tab) which are not in the toml spec. + # it would strip out backslashes inappropriately: e.g "\j" becomes just j + # it recognizes other escapes which aren't approprite e.g \xhh and octal \nnn + # it replaces \ with a single whitespace (trailing backslash) + #This means we shouldn't use 'subst' on the whole string, but instead substitute only the toml-specified escapes (\r \n \b \t \f \\ \" \uhhhh & \Uhhhhhhhh + + set buffer "" + set buffer4 "" ;#buffer for 4 hex characters following a \u + set buffer8 "" ;#buffer for 8 hex characters following a \u + + set sLen [tcl::string::length $str] + + #we need to handle arbitrarily long sequences of backslashes. \\\\\ etc + set slash_active 0 + set unicode4_active 0 + set unicode8_active 0 + + ::tomlish::log::debug "unescape_string. got len [string length str] str $str" + + #!todo - check for invalid data in the form of a raw carriage return (decimal 13) without following linefeed? + set i 0 + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $str [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $str $i] + #::tomlish::log::debug "unescape_string. got char $c" ;#too much? + + #---------------------- + #as we are 'unescaping' - should we really be testing for existing values that should have been escaped? + #this test looks incomplete anyway REVIEW + scan $c %c n + if {($n <= 31) && ($n != 9) && ($n != 10) && ($n != 13)} { + #we don't expect unescaped unicode characters from 0000 to 001F - + #*except* for raw tab (which is whitespace) and newlines + error "unescape_string. Invalid data for a toml string. Unescaped control character (decimal $n) [::tomlish::utils::string_to_slashu $c]" + } + #---------------------- + + incr i ;#must incr here because we do'returns'inside the loop + if {$c eq "\\"} { + if {$slash_active} { + append buffer "\\" + set slash_active 0 + } elseif {$unicode4_active} { + error "unescape_string. unexpected case slash during unicode4 not yet handled" + } elseif {$unicode8_active} { + error "unescape_string. unexpected case slash during unicode8 not yet handled" + } else { + # don't output anything (yet) + set slash_active 1 + } + } else { + if {$unicode4_active} { + if {[tcl::string::length $buffer4] < 4} { + append buffer4 $c + } + if {[tcl::string::length $buffer4] == 4} { + #we have a \uHHHH to test + set unicode4_active 0 + set result [tomlish::utils::unicode_escape_info "\\u$buffer4"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$unicode8_active} { + if {[tcl::string::length $buffer8] < 8} { + append buffer8 $c + } + if {[tcl::string::length $buffer8] == 8} { + #we have a \UHHHHHHHH to test + set unicode8_active 0 + set result [tomlish::utils::unicode_escape_info "\\U$buffer8"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$slash_active} { + set slash_active 0 + set ctest [tcl::string::map {{"} dq} $c] + switch -exact -- $ctest { + dq { + set e "\\\"" + append buffer [subst -nocommand -novariable $e] + } + b - t - n - f - r { + set e "\\$c" + append buffer [subst -nocommand -novariable $e] + } + u { + set unicode4_active 1 + set buffer4 "" + } + U { + set unicode8_active 1 + set buffer8 "" + } + default { + set slash_active 0 + #review - toml spec says all other escapes are reserved + #and if they are used TOML should produce an error. + #we leave detecting this for caller for now - REVIEW + append buffer "\\" + append buffer $c + } + } + } else { + append buffer $c + } + } + } + #puts stdout "EOF 4:$unicode4_active 8:$unicode8_active slash:$slash_active" + if {$unicode4_active} { + error "End of string reached before complete unicode escape sequence \uHHHH" + } + if {$unicode8_active} { + error "End of string reached before complete unicode escape sequence \UHHHHHHHH" + } + if {$slash_active} { + append buffer "\\" + } + return $buffer + } + + #This does not have to do with unicode normal forms - which it seems toml has decided against regarding use in keys (review/references?) + #This is meant for internal use regarding ensuring we match equivalent keys which may have just been specified with different string mechanisms, + #e.g squoted vs dquoted vs barekey. + proc normalize_key {rawkey} { + set c1 [tcl::string::index $rawkey 0] + set c2 [tcl::string::index $rawkey end] + if {($c1 eq "'") && ($c2 eq "'")} { + #single quoted segment. No escapes allowed within it. + set key [tcl::string::range $rawkey 1 end-1] + } elseif {($c1 eq "\"") && ($c2 eq "\"")} { + #double quoted segment. Apply escapes. + # + set keydata [tcl::string::range $rawkey 1 end-1] ;#strip outer quotes only + #e.g key could have mix of \UXXXXXXXX escapes and unicode chars + #or mix of \t and literal tabs. + #unescape to convert all to literal versions for comparison + set key [::tomlish::utils::unescape_string $keydata] + #set key [subst -nocommands -novariables $keydata] ;#wrong. Todo - create a string escape substitution function. + } else { + set key $rawkey + } + return $key + } + + proc string_to_slashu {string} { + set rv {} + foreach c [split $string {}] { + scan $c %c cdec + if {$cdec > 65535} { + append rv {\U} [format %.8X $cdec] + } else { + append rv {\u} [format %.4X $cdec] + } + } + return $rv + } + + #'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. + #This is used for display purposes only (error msgs) + proc nonprintable_to_slashu {s} { + set res "" + foreach i [split $s ""] { + scan $i %c cdec + + set printable 0 + if {($cdec>31) && ($cdec<127)} { + set printable 1 + } + if {$printable} { + append res $i + } else { + if {$cdec > 65535} { + append res \\U[format %.8X $cdec] + } else { + append res \\u[format %.4X $cdec] + } + } + } + set res + } ;# initial version from tcl wiki RS + + #check if str is valid for use as a toml bare key + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } else { + set matches [regexp -all {[a-zA-Z0-9\_\-]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters match the regexp + return 1 + } else { + return 0 + } + } + } + + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + + #test only that the characters in str are valid for the toml specified type 'integer'. + proc int_validchars1 {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_\-\+]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + #add support for hex,octal,binary 0x.. 0o.. 0b... + proc int_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_int {str} { + set matches [regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + + # --------------------------------------- + #check for leading zeroes in non 0x 0b 0o + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + if {([tcl::string::length $check] > 1) && ([tcl::string::index $check 0] eq "0") && ([tcl::string::index $check 1] ni {o x b})} { + return 0 + } + # --------------------------------------- + + #check +,- only occur in the first position. + if {[tcl::string::last - $str] > 0} { + return 0 + } + if {[tcl::string::last + $str] > 0} { + return 0 + } + set numeric_value [tcl::string::map {_ ""} $str] ;#allow some earlier tcl versions which don't support underscores + #use Tcl's integer check to ensure we don't let things like 3e4 through - which is a float (would need to be 0x3e4 for hex) + if {![tcl::string::is integer -strict $numeric_value]} { + return 0 + } + #!todo - check bounds only based on some config value + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements. + #presumably very large numbers would have to be supplied in a toml file as strings. + #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max + if {$numeric_value > $::tomlish::max_int} { + return 0 + } + if {$numeric_value < $::tomlish::min_int} { + return 0 + } + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'float'. + proc float_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[eE0-9\_\-\+\.]} $str] == $numchars} { + return 1 + } else { + #only allow lower case for these special values - as per Toml 1.0 spec + if {$str ni {inf +inf -inf nan +nan -nan}} { + return 0 + } else { + return 1 + } + } + } + + proc is_float {str} { + set matches [regexp -all {[eE0-9\_\-\+\.]} $str] + #don't test for case variations - as Toml doesn't allow (whereas Tcl allows Inf NaN etc) + if {$str in {inf +inf -inf nan +nan -nan}} { + return 1 + } + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + #A leading zero is ok, but we should disallow multiple leading zeroes (same rules as toml ints) + #Toml spec also disallows leading zeros in the exponent part + #... but this seems less interoperable (some libraries generate leading zeroes in exponents) + #for now we will allow leading zeros in exponents + #!todo - configure 'strict' option to disallow? + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + set r {([0-9])*} + regexp $r $check intpart ;#intpart holds all numerals before the first .,e or E + set z {([0])*} + regexp $z $intpart leadingzeros + if {[tcl::string::length $leadingzeros] > 1} { + return 0 + } + #for floats, +,- may occur in multiple places + #e.g -2E-22 +3e34 + #!todo - check bounds ? + + #strip underscores for tcl double check + set check [tcl::string::map {_ ""} $str] + #string is double accepts inf nan +NaN etc. + if {![tcl::string::is double $check]} { + return 0 + } + + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'datetime'. + proc datetime_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[zZtT0-9\-\+\.:]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + #review - we + proc is_datetime {str} { + #e.g 1979-05-27 + #e.g 1979-05-27T00:32:00Z + #e.g 1979-05-27 00:32:00-07:00 + #e.g 1979-05-27 00:32:00+10:00 + #e.g 1979-05-27 00:32:00.999999-07:00 + + #review + #minimal datetimes? + # 2024 ok - shortest valid 4 digit year? + # 02:00 ok + # 05-17 ok + if {[string length $str] < 4} { + return 0 + } + + set matches [regexp -all {[zZtT0-9\-\+\.:]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + #!todo - use full RFC 3339 parser? + lassign [split $str T] datepart timepart + #!todo - what if the value is 'time only'? + + #Tcl's free-form clock scan (no -format option) is deprecated + # + #if {[catch {clock scan $datepart} err]} { + # puts stderr "tcl clock scan failed err:'$err'" + # return 0 + #} + + #!todo - verify time part is reasonable + } else { + return 0 + } + return 1 + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::utils ---}] +} + +namespace eval tomlish::parse { + #*** !doctools + #[subsection {Namespace tomlish::parse}] + #[para] + #[list_begin definitions] + + #This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases. + #The code is a pig's-nest - but it should be noted that for example trailing single double quotes in multiline strings are perhaps not so trivial to parse using more standard methods either: + # - e.g some kind of backtracking required if using an ABNF parser? + #I don't know the precise technical name for this sort of parser; probably something like "Dog's Breakfast" + #More seriously, we don't have distinct lex/parse steps - so it is basically a 'fused lexer' or 'scannerless parser' + + #It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? + + #A possible alternative more structured approach might be to use a PEG (Parsing Expression Grammar) + + + variable is_parsing 0 ;#whether we are in the middle of parsing tomlish text + + variable state + # states: + # table-space, itable-space, array-space + # value-expected, keyval-syntax, + # quoted-key, squoted-key + # string-state, literal-state, multistring... + # + # notes: + # only the -space states are also 'spaces' ie a container which is pushed/popped on the spacestack + + # + # value-expected - we also allow for leading whitespace in this state, but once a value is returned we jump to a state based on the containing space. e.g keyval-tail or array-syntax + # + #stateMatrix defines for each state, actions to take for each possible token. + #single-element actions are the name of the next state into which to transition, or a 'POPSPACE' instruction to pop a level off the spacestack and add the data to the parent container. + #dual-element actions are a push instruction and the name of the space to push on the stack. + # - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) + + # -- --- --- --- --- --- + #token/state naming guide + # -- --- --- --- --- --- + #tokens : underscore separated or bare name e.g newline, start_quote, start_squote + #private tokens: always have a leading underscore (These are private 'temporary state' tokens that are never returned as actual tokens e.g _start_squote_sequence + #states : always contain at least one dash e.g err-state, table-space + #instructions + # -- --- --- --- --- --- + + + #stateMatrix dict of elements mapping current state to next state based on returned tokens + # current-state {token-encountered next-state ... } + # where next-state can be a 1 or 2 element list. + #If 2 element - the first item is an instruction (ucase) + #If 1 element - it is either a lowercase dashed state name or an ucase instruction + #e.g {PUSHSPACE } or POPSPACE or SAMESPACE + + + #SAMESPACE - got to same space as parent without popping a level, but has it's own autotransition lookup - strange concept - review usecases + + variable stateMatrix + set stateMatrix [dict create] + + #xxx-space vs xxx-syntax inadequately documented - TODO + + # --------------------------------------------------------------------------------------------------------------# + # incomplete example of some state starting at table-space + # --------------------------------------------------------------------------------------------------------------# + # ( = -> value-expected) + # keyval-syntax (popped -> keyval-space -> keyval-tail) (autotransition on pop) + # keyval-space (autotransition on push ^) + # table-space (barekey^) (startdquote -> dquoted-key ^) + # --------------------------------------------------------------------------------------------------------------# + + dict set stateMatrix\ + table-space { + bom "table-space"\ + whitespace "table-space"\ + newline "table-space"\ + barekey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + squotedkey {PUSHSPACE "keyval-space" state "keyval-syntax" note ""}\ + dquotedkey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + XXXstartquote "quoted-key"\ + XXXstartsquote "squoted-key"\ + comment "table-space"\ + starttablename "tablename-state"\ + starttablearrayname "tablearrayname-state"\ + startmultiquote "err-state"\ + endquote "err-state"\ + comma "err-state"\ + eof "end-state"\ + equal "err-state"\ + cr "err-lonecr"\ + } + + #itable-space/ curly-syntax : itables + dict set stateMatrix\ + itable-space {\ + whitespace "itable-space"\ + newline "itable-space"\ + barekey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + dquotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + endinlinetable "POPSPACE"\ + XXXstartquote "quoted-key"\ + XXXstartsquote {TOSTATE "squoted-key" comment "jn-testing"}\ + comma "err-state"\ + comment "itable-space"\ + eof "err-state"\ + } + #squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-space starttok {squote_seq "'"}} + + + dict set stateMatrix\ + keyval-space {\ + whitespace "keyval-syntax"\ + equal "keyval-value-expected"\ + } + + # ' = ' portion of keyval + dict set stateMatrix\ + keyval-syntax {\ + whitespace "keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "keyval-value-expected"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + #### + dict set stateMatrix\ + keyval-value-expected {\ + whitespace "keyval-value-expected"\ + untyped_value {TOSTATE "keyval-tail" note ""}\ + squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate keyval-value-expected starttok {squote_seq "'"}}\ + startquote {TOSTATE "string-state" returnstate keyval-tail}\ + startmultiquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + startsquote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + double_squote {TOSTATE "keyval-tail" note "empty literal received when double squote occurs"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + } + #squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate keyval-process-leading-squotes starttok {squote_seq "'"}} + dict set stateMatrix\ + leading-squote-space {\ + squote_seq "POPSPACE"\ + } + #dict set stateMatrix\ + # keyval-process-leading-squotes {\ + # startsquote "literal-state"\ + # triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + # } + + dict set stateMatrix\ + keyval-tail {\ + whitespace "keyval-tail"\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + dict set stateMatrix\ + itable-keyval-syntax {\ + whitespace "itable-keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "itable-keyval-value-expected"\ + newline "err-state"\ + eof "err-state"\ + } + dict set stateMatrix\ + itable-keyval-value-expected {\ + whitespace "itable-keyval-value-expected"\ + untyped_value {TOSTATE "itable-val-tail" note ""}\ + squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-keyval-value-expected starttok {squote_seq "'"}}\ + startquote {TOSTATE "string-state" returnstate itable-val-tail}\ + startmultiquote {PUSHSPACE "multistring-space" returnstate itable-val-tail}\ + startsquote {TOSTATE "literal-state" returnstate itable-val-tail note "usual way a literal is triggered"}\ + double_squote {TOSTATE "itable-val-tail" note "empty literal received when double squote occurs"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate itable-val-tail}\ + startinlinetable {PUSHSPACE "itable-space" returnstate itable-val-tail}\ + startarray {PUSHSPACE "array-space" returnstate itable-val-tail}\ + } + dict set stateMatrix\ + itable-keyval-space {\ + whitespace "itable-keyval-syntax"\ + equal {TOSTATE "itable-keyval-value-expected" note "required"}\ + } + + dict set stateMatrix\ + itable-val-tail {\ + whitespace "itable-val-tail"\ + endinlinetable "POPSPACE"\ + comma "POPSPACE"\ + XXXnewline {TOSTATE "itable-val-tail" note "itable-space ??"}\ + newline "POPSPACE"\ + comment "itable-val-tail"\ + eof "err-state"\ + } + #dict set stateMatrix\ + # itable-quoted-key {\ + # whitespace "NA"\ + # itablequotedkey {PUSHSPACE "itable-keyval-space"}\ + # newline "err-state"\ + # endquote "itable-keyval-syntax"\ + # } + #dict set stateMatrix\ + # itable-squoted-key {\ + # whitespace "NA"\ + # itablesquotedkey {PUSHSPACE "itable-keyval-space"}\ + # newline "err-state"\ + # endsquote "itable-keyval-syntax"\ + # } + + + + + + dict set stateMatrix\ + value-expected {\ + whitespace "value-expected"\ + untyped_value {"SAMESPACE" "" replay untyped_value}\ + startquote "string-state"\ + startsquote "literal-state"\ + startmultiquote {PUSHSPACE "multistring-space"}\ + triple_squote {PUSHSPACE "multiliteral-space"}\ + startinlinetable {PUSHSPACE itable-space}\ + startarray {PUSHSPACE array-space}\ + comment "err-state-value-expected-got-comment"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + + #dottedkey-space is not (currently) used within [tablename] or [[tablearrayname]] + #it is for keyval ie x.y.z = value + + #this is the state after dot + #we are expecting a complete key token or whitespace + #(initial entry to the space is by one of the keys - which will immediately go to dottedkey-space-tail) + dict set stateMatrix\ + dottedkey-space {\ + whitespace "dottedkey-space"\ + dotsep "err-state"\ + barekey "dottedkey-space-tail"\ + squotedkey "dottedkey-space-tail"\ + dquotedkey "dottedkey-space-tail"\ + newline "err-state"\ + comma "err-state"\ + comment "err-state"\ + equal "err-state"\ + } + #dottedkeyend "POPSPACE" + #equal "POPSPACE"\ + + #jmn 2025 + #we have 1 or more dottedkeys so far - need dotsep to add more, whitespace to maintain, equal to pop + dict set stateMatrix\ + dottedkey-space-tail {\ + whitespace "dottedkey-space-tail" + dotsep "dottedkey-space" + equal "POPSPACE"\ + } + + #-------------------------------------------------------------------------- + #scratch area + #from_toml {x=1} + # barekey tok + # table-space PUSHSPACE keyval-space state keyval-syntax + # + + + #-------------------------------------------------------------------------- + + + #REVIEW + #toml spec looks like heading towards allowing newlines within inline tables + #https://github.com/toml-lang/toml/issues/781 + + #2025 - appears to be valid for 1.1 - which we are targeting. + #https://github.com/toml-lang/toml/blob/main/toml.md#inline-table + + #JMN2025 + #dict set stateMatrix\ + # curly-syntax {\ + # whitespace "curly-syntax"\ + # newline "curly-syntax"\ + # barekey {PUSHSPACE "itable-keyval-space"}\ + # itablequotedkey "itable-keyval-space"\ + # endinlinetable "POPSPACE"\ + # startquote "itable-quoted-key"\ + # comma "itable-space"\ + # comment "itable-space"\ + # eof "err-state"\ + # } + #review comment "err-state" vs comment "itable-space" - see if TOML 1.1 comes out and allows comments in multiline ITABLES + #We currently allow multiline ITABLES (also with comments) in the tokenizer. + #if we want to disallow as per TOML 1.0 - we should do so when attempting to get structure? + + + #JMN REVIEW + dict set stateMatrix\ + array-space {\ + whitespace "array-space"\ + newline "array-space"\ + untyped_value "SAMESPACE"\ + startarray {PUSHSPACE "array-space"}\ + endarray "POPSPACE"\ + startmultiquote {PUSHSPACE multistring-space}\ + startinlinetable {PUSHSPACE itable-space}\ + startquote "string-state"\ + startsquote "literal-state"\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax note "seems ok 2024"}\ + comma "array-space"\ + comment "array-space"\ + eof "err-state-array-space-got-eof"\ + } + dict set stateMatrix\ + array-syntax {\ + whitespace "array-syntax"\ + newline "array-syntax"\ + untyped_value "SAMESPACE"\ + startarray {PUSHSPACE array-space}\ + endarray "POPSPACE"\ + startmultiquote {PUSHSPACE multistring-space}\ + startquote "string-state"\ + startsquote "literal-state"\ + comma "array-space"\ + comment "err-state"\ + } + + + + #quoted-key & squoted-key need to PUSHSPACE from own token to keyval-space + dict set stateMatrix\ + quoted-key {\ + whitespace "NA"\ + dquotedkey {PUSHSPACE "keyval-space"}\ + newline "err-state"\ + endquote "keyval-syntax"\ + } + + + #review + dict set stateMatrix\ + dquoted-key {\ + whitespace "NA"\ + dquotedkey "dquoted-key"\ + newline "err-state"\ + } + dict set stateMatrix\ + squoted-key {\ + whitespace "NA"\ + squotedkey "squoted-key"\ + newline "err-state"\ + } + # endsquote {PUSHSPACE "keyval-space"} + + dict set stateMatrix\ + string-state {\ + whitespace "NA"\ + string "string-state"\ + endquote "SAMESPACE"\ + newline "err-state"\ + eof "err-state"\ + } + dict set stateMatrix\ + literal-state {\ + whitespace "NA"\ + literal "literal-state"\ + endsquote "SAMESPACE"\ + newline "err-state"\ + eof "err-state"\ + } + + + #dict set stateMatrix\ + # stringpart {\ + # continuation "SAMESPACE"\ + # endmultiquote "POPSPACE"\ + # eof "err-state"\ + # } + dict set stateMatrix\ + multistring-space {\ + whitespace "multistring-space"\ + continuation "multistring-space"\ + stringpart "multistring-space"\ + newline "multistring-space"\ + endmultiquote "POPSPACE"\ + eof "err-state"\ + } + + + #only valid subparts are literalpart and newline. other whitespace etc is within literalpart + #todo - treat sole cr as part of literalpart but crlf and lf as newline + dict set stateMatrix\ + multiliteral-space {\ + literalpart "multiliteral-space"\ + newline "multiliteral-space"\ + squote_seq_begin {PUSHSPACE "trailing-squote-space" returnstate multiliteral-space starttok {squote_seq "'"}}\ + triple_squote {POPSPACE note "on popping - we do any necessary concatenation of LITERALPART items due to squote processing"}\ + double_squote {TOSTATE multiliteral-space note "short squote_seq: can occur anywhere in the space e.g emitted at end when 5 squotes occur"}\ + startsquote {TOSTATE multiliteral-space note "short squote_seq: same as double_squote - false alarm"}\ + eof "err-premature-eof-in-multiliteral-space"\ + } + + #trailing because we are looking for possible terminating ''' - but must accept '''' or ''''' and re-integrate the 1st one or 2 extra squotes + dict set stateMatrix\ + trailing-squote-space {\ + squote_seq "POPSPACE"\ + } + + + dict set stateMatrix\ + tablename-state {\ + whitespace "NA"\ + tablename {zeropoppushspace table-space}\ + tablename2 {PUSHSPACE table-space}\ + endtablename "tablename-tail"\ + comma "err-state"\ + newline "err-state"\ + } + dict set stateMatrix\ + tablearrayname-state {\ + whitespace "NA"\ + tablearrayname {zeropoppushspace table-space}\ + tablearrayname2 {PUSHSPACE table-space}\ + endtablearray "tablearrayname-tail"\ + comma "err-state"\ + newline "err-state"\ + } + + dict set stateMatrix\ + tablename-tail {\ + whitespace "tablename-tail"\ + newline "table-space"\ + comment "tablename-tail"\ + eof "end-state"\ + } + dict set stateMatrix\ + tablearrayname-tail {\ + whitespace "tablearrayname-tail"\ + newline "table-space"\ + comment "tablearrayname-tail"\ + eof "end-state"\ + } + dict set stateMatrix\ + end-state {} + + set knowntokens [list] + set knownstates [list] + dict for {state transitions} $stateMatrix { + if {$state ni $knownstates} {lappend knownstates $state} + dict for {tok instructions} $transitions { + if {$tok ni $knowntokens} {lappend knowntokens $tok} + } + } + dict set stateMatrix nostate {} + foreach tok $knowntokens { + dict set stateMatrix nostate $tok "err-nostate-received-token-$tok" + } + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #purpose - debugging? remove? + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #build a list of 'push triggers' from the stateMatrix + # ie tokens which can push a new space onto spacestack + set push_trigger_tokens [list] + tcl::dict::for {s transitions} $stateMatrix { + tcl::dict::for {token transition_to} $transitions { + set instruction [lindex $transition_to 0] + switch -exact -- $instruction { + PUSHSPACE - zeropoppushspace { + if {$token ni $push_trigger_tokens} { + lappend push_trigger_tokens $token + } + } + } + } + } + ::tomlish::log::debug "push_trigger_tokens: $push_trigger_tokens" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + + #This seems hacky... (deprecate in favour of explicit arguments to the instructions in stateMatrix?) + #spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE + + #mainly for the -space states: + #redirect to another state $c based on a state transition from $whatever to $b + # e.g "string {array-space array-syntax}" means when transitioning from string to array-space, jump to array-syntax instead. + #this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' + + #Push to, next + #default first states when we push to these spaces + variable spacePushTransitions { + keyval-space keyval-syntax + itable-keyval-space itable-keyval-syntax + array-space array-space + table-space tablename-state + } + #itable-space itable-space + #Pop to, next + variable spacePopTransitions { + array-space array-syntax + } + #itable-space curly-syntax + #itable-keyval-space itable-val-tail + #review + #we pop to keyval-space from dottedkey-space or from value-expected? we don't always want to go to keyval-tail + #leave it out and make the POPSPACE caller explicitly specify it + #keyval-space keyval-tail + + variable spaceSameTransitions { + array-space array-syntax + } + #itable-space curly-syntax + #itable-keyval-space itable-val-tail + + + variable state_list ;#reset every tomlish::decode::toml + + namespace export tomlish toml + namespace ensemble create + + #goNextState has various side-effects e.g pushes and pops spacestack + #REVIEW - setting nest and v elements here is ugly + #todo - make neater, more single-purpose? + proc goNextState {tokentype tok currentstate} { + variable state + variable nest + variable v + + set prevstate $currentstate + + + variable spacePopTransitions + variable spacePushTransitions + variable spaceSameTransitions + + variable last_space_action "none" + variable last_space_type "none" + variable state_list + + set result "" + set starttok "" + + if {[dict exists $::tomlish::parse::stateMatrix $currentstate $tokentype]} { + set transition_to [dict get $::tomlish::parse::stateMatrix $currentstate $tokentype] + ::tomlish::log::debug "--->> goNextState tokentype:$tokentype tok:$tok currentstate:$currentstate : transition_to = $transition_to" + switch -exact -- [lindex $transition_to 0] { + POPSPACE { + spacestack pop + set parent_info [spacestack peek] + set type [dict get $parent_info type] + set parentspace [dict get $parent_info state] + + set last_space_action "pop" + set last_space_type $type + + if {[dict exists $parent_info returnstate]} { + set next [dict get $parent_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace redirected to stored returnstate $next <<---" + } else { + ### + #review - do away with spacePopTransitions - which although useful to provide a default.. + # - involve error-prone configurations distant to the main state transition configuration in stateMatrix + if {[dict exists $::tomlish::parse::spacePopTransitions $parentspace]} { + set next [dict get $::tomlish::parse::spacePopTransitions $parentspace] + ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace redirected state to $next (spacePopTransitions)<<---" + } else { + set next $parentspace + ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace<<---" + } + } + set result $next + } + SAMESPACE { + set currentspace_info [spacestack peek] + ::tomlish::log::debug "--->> SAMESPACE got current space entry: $currentspace_info <<<<<" + set type [dict get $currentspace_info type] + set currentspace [dict get $currentspace_info state] + + if {[dict exists $currentspace_info returnstate]} { + set next [dict get $currentspace_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected to stored returnstate $next" + } else { + if {[dict exists $::tomlish::parse::spaceSameTransitions $currentspace]} { + set next [dict get $::tomlish::parse::spaceSameTransitions $currentspace] + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected state to $next (spaceSameTransitions)" + } else { + set next $currentspace + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace" + } + } + set result $next + } + zeropoppushspace { + if {$nest > 0} { + #pop back down to the root level (table-space) + spacestack pop + set parentinfo [spacestack peek] + set type [dict get $parentinfo type] + set target [dict get $parentinfo state] + + set last_space_action "pop" + set last_space_type $type + + #----- + #standard pop + set parentlevel [expr {$nest -1}] + lappend v($parentlevel) [set v($nest)] + incr nest -1 + #----- + } + #re-entrancy + + #set next [list PUSHSPACE [lindex $transition_to 1]] + set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 + #::tomlish::log::notice "goNextState REENTRANCY. calling goNextState $nexttokentype $tokentype" + #set result [::tomlish::parse::goNextState $nexttokentype $tokentype] + ::tomlish::log::debug "--->> zeropoppushspace goNextState REENTRANCY. calling goNextState $nexttokentype $currentstate" + set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] + set result [dict get $transition_info newstate] + } + PUSHSPACE { + set original_target [dict get $transition_to PUSHSPACE] + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + if {[dict exists $transition_to starttok]} { + set starttok [dict get $transition_to starttok] + } + spacestack push [dict create type space state $original_target] + + set last_space_action "push" + set last_space_type "space" + + if {[dict exists $transition_to state]} { + #an explicit state in the pushed space was requested in the stateMatrix - override the spacePushTransition (spacePushTransitions can be deprecated if we require explicitness?) + set next [dict get $transition_to state] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next by explicit 'state' entry" + } else { + #puts $::tomlish::parse::spacePushTransitions + if {[dict exists $::tomlish::parse::spacePushTransitions $original_target]} { + set next [dict get $::tomlish::parse::spacePushTransitions $original_target] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next (spacePushTransitions) " + } else { + set next $original_target + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target" + } + } + set result $next + } + TOSTATE { + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + set result [dict get $transition_to TOSTATE] + } + default { + #simplified version of TOSTATE + set result [lindex $transition_to 0] ;#ignore everything but first word + } + } + } else { + ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" + set result "nostate" + } + lappend state_list [list tokentype $tokentype from $currentstate to $result] + set state $result + ::tomlish::log::notice "--->> STATE TRANSITION tokenType: '$tokentype' tok:$tok triggering '$currentstate' -> '$result' last_space_action:$last_space_action " + return [dict create prevstate $prevstate newstate $result space_action $last_space_action starttok $starttok] + } + + proc report_line {{line ""}} { + variable linenum + variable is_parsing + if {$is_parsing} { + if {$line eq ""} { + set line $linenum + } + return "Line Number: $line" + } else { + #not in the middle of parsing tomlish text - return nothing. + return "" + } + } + + #produce a *slightly* more readable string rep of the nest for puts etc. + proc nest_pretty1 {list} { + set prettier "{" + + foreach el $list { + if { [lindex $el 0] eq "NEWLINE"} { + append prettier "[list $el]\n" + } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY DQKEY SQKEY TABLE ARRAY})} { + append prettier [nest_pretty1 $el] + } else { + append prettier "[list $el] " + } + } + append prettier "}" + return $prettier + } + + proc set_tokenType {t} { + variable tokenType + variable tokenType_list + if {![info exists tokenType]} { + set tokenType "" + } + lappend tokenType_list $t + set tokenType $t + } + + proc switch_tokenType {t} { + variable tokenType + variable tokenType_list + lset tokenType_list end $t + set tokenType $t + } + + proc get_tokenType {} { + variable tokenType + return $tokenType + } + + proc _shortcircuit_startquotesequence {} { + variable tok + variable i + set toklen [tcl::string::length $tok] + if {$toklen == 1} { + set_tokenType "startquote" + incr i -1 + return -level 2 1 + } elseif {$toklen == 2} { + puts stderr "_shortcircuit_startquotesequence toklen 2" + set_tokenType "startquote" + set tok "\"" + incr i -2 + return -level 2 1 + } + } + + proc get_token_waiting {} { + variable token_waiting + return [lindex $token_waiting 0] + } + proc clear_token_waiting {} { + variable token_waiting + set token_waiting [list] + } + + #token_waiting is a list - but our standard case is to have only one + #in certain circumstances such as near eof we may have 2 + #the set_token_waiting function only allows setting when there is not already one waiting. + #we want to catch cases of inadvertently trying to set multiple + # - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. + proc set_token_waiting {args} { + if {[llength $args] %2 != 0} { + error "tomlish set_token_waiting must have args of form: type value complete 0|1" + } + variable token_waiting + + if {[llength $token_waiting] && [dict get [lindex $token_waiting end] type] ne "eof"} { + #tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another + #we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context + #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it + set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" + append err \n " - cannot add token_waiting: $args" + error $err + #set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] + #set token_waiting [list] + } + + set waiting [dict create] + dict for {k v} $args { + switch -exact $k { + type - complete { + dict set waiting $k $v + } + value { + dict set waiting tok $v + } + startindex { + dict set waiting startindex $v + } + default { + error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" + } + } + } + if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { + error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" + } + if {![llength $token_waiting]} { + set token_waiting [list $waiting] + } else { + #an extra sanity-check that we don't have more than just the eof.. + if {[llength $token_waiting] > 1} { + set err "tomlish Unexpected. Existing token_waiting count > 1.\n" + foreach tw $token_waiting { + append err " $tw" \n + } + append err " - cannot add token_waiting: $waiting" + error $err + } + #last entry must be a waiting eof + set token_waiting [list $waiting [lindex $token_waiting end]] + } + return + } + + #returns 0 or 1 + #tomlish::parse::tok + #we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag + # - the possible benefit is being able to more easily process in arbitrarily split chunks (although we would still have to watch crlf splitting ?) + # - interactive use? + + proc tok {s} { + variable nest + variable v + variable i + variable tok + variable type ;#character type + variable state ;#FSM + + + variable tokenType + variable tokenType_list + + + variable endToken + + variable lastChar + + variable braceCount + variable bracketCount + + + #------------------------------ + #Previous run found another (presumably single-char) token + #The normal case is for there to be only one dict in the list + #multiple is an exception - primarily for eof + variable token_waiting + if {[llength $token_waiting]} { + set waiting [lindex $token_waiting 0] + + set tokenType [dict get $waiting type] + set tok [dict get $waiting tok] + #todo: dict get $token_waiting complete + set token_waiting [lrange $token_waiting 1 end] + return 1 + } + #------------------------------ + + set resultlist [list] + set sLen [tcl::string::length $s] + + set slash_active 0 + set quote 0 + set c "" + set multi_dquote "" + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $s [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $s $i] + set cindex $i + set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] + tomlish::log::debug "- tokloop char <$ctest> index $i tokenType:$tokenType tok:<$tok>" + #puts "got char $c during tokenType '$tokenType'" + incr i ;#must incr here because we do returns inside the loop + + switch -exact -- $ctest { + # { + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {$had_slash} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + barekey { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" + } + whitespace { + # hash marks end of whitespace token + #do a return for the whitespace, set token_waiting + #set_token_waiting type comment value "" complete 1 + incr i -1 ;#leave comment for next run + return 1 + } + untyped_value { + #REVIEW! the spec isn't clear.. is whitespace after an int,bool etc required before comment? + #we will accept a comment marker as an immediate terminator of the untyped_value. + incr i -1 + return 1 + } + starttablename - starttablearrayname { + #fix! + error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out + append tok $c + } + default { + #dquotedkey, itablequotedkey, string,literal, multistring + append tok $c + } + } + } else { + switch -- $state { + multistring-space { + set_tokenType stringpart + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes#" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "#" + } + default { + #start of token if we're not in a token + set_tokenType comment + set tok "" ;#The hash is not part of the comment data + } + } + } + } + lc { + #left curly brace + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + starttablename - starttablearrayname { + #*bare* tablename can only contain letters,digits underscores + error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #valid in quoted parts + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + switch -exact -- $state { + itable-keyval-value-expected - keyval-value-expected - value-expected { + #switch last key to tablename?? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + array-space - array-syntax { + #nested anonymous inline table + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\{" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\{" + } + default { + error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" + } + } + } + + } + rc { + #right curly brace + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey - comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + starttablename - tablename { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endinlinetable value "" complete 1 startindex $cindex + return 1 + } + starttablearrayname - tablearrayname { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + #end any other token + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + value-expected { + #invalid - but allow parser statemachine to report it. + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-space { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname-state problem" + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + #invalid + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + XXXcurly-syntax { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-val-tail { + set_tokenType "endinlinetable" + set tok "" + #we need to pop the keyval - and then reprocess to pop the inlinetable - so we incr -1 + incr i -1 + return 1 + } + itable-keyval-syntax { + error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\}" + } + multiliteral-space { + set_tokenType "literalpart" ; #review + set tok "\}" + } + default { + #JMN2024b keyval-tail? + error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" + } + } + } + + } + lb { + #left square bracket + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + starttablename { + #change the tokenType + switch_tokenType "starttablearrayname" + set tok "" ;#no output into the tomlish list for this token + #any following whitespace is part of the tablearrayname, so return now + return 1 + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + #append tok "\\[" + append tok {\[} + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + #invalid at this point - state machine should disallow table -> starttablearrayname + set_token_waiting type starttablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "\[" + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + keyval-value-expected - itable-keyval-value-expected - value-expected { + set_tokenType "startarray" + set tok "\[" + return 1 + } + table-space { + #table name + #assume it's a single bracket - but we need to wait for non-bracket to confirm it's not a tablearray + #note that a starttablearrayname token may contain whitespace between the brackets + # e.g \[ \[ + set_tokenType "starttablename" + set tok "" ;#there is no output into the tomlish list for this token + } + array-space - array-syntax { + #nested array? + set_tokenType "startarray" + set tok "\[" + return 1 + #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\[" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\[" + } + itable-space { + #handle state just to give specific error msg + error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[\] syntax. [tomlish::parse::report_line]" + } + default { + error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + rb { + #right square bracket + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + #???? + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } else { + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablename value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + tablearraynames { + #todo? + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + value-expected { + #invalid - but allow parser statemachine to report it. + set_tokenType "endarray" + set tok "\]" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endarray" + set tok "\]" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endtablename" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname problem" + set_tokenType "endtablearray" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + set_tokenType "endarray" + set tok "\]" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\]" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\]" + } + default { + error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + bsl { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + #backslash + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + #end whitespace token + incr i -1 ;#reprocess bsl in next run + return 1 + } else { + error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" + } + } + literal - literalpart - squotedkey { + #never need to set slash_active true when in single quoted tokens + append tok "\\" + set slash_active 0 + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey - comment { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + stringpart { + if {$slash_active} { + #assert - quotes empty - or we wouldn't have slash_active + set slash_active 0 + append tok "\\\\" + } else { + append tok $dquotes + set slash_active 1 + } + } + starttablename - starttablearrayname { + error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" + } + tablename - tablearrayname { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + barekey { + error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" + } + default { + error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$slash_active} { + set_tokenType "stringpart" + set tok "\\\\" + set slash_active 0 + } else { + if {$dquotes ne ""} { + set_tokenType "stringpart" + set tok $dquotes + } + set slash_active 1 + } + } + multiliteral-space { + #nothing can be escaped in multiliteral-space - not even squotes (?) review + set_tokenType "literalpart" + set tok "\\" + } + default { + error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" + } + } + } + } + sq { + #single quote + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + #short squote_seq tokens are returned if active during any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + switch -- $state { + leading-squote-space { + append tok $c + if {$existingtoklen > 2} { + error "tomlish tok error: squote_seq unexpected length $existingtoklen when another received" + } elseif {$existingtoklen == 2} { + return 1 ;#return tok ''' + } + } + trailing-squote-space { + append tok $c + if {$existingtoklen == 4} { + #maxlen to be an squote_seq is multisquote + 2 = 5 + #return tok ''''' + return 1 + } + } + default { + error "tomlish tok error: squote_seq in unexpected state '$state' - expected leading-squote-space or trailing-squote-space" + } + } + } + whitespace { + #end whitespace + incr i -1 ;#reprocess sq + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + #temp token creatable only during value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + append tok $c + } + 2 { + #switch? + append tok $c + set_tokenType triple_squote + return 1 + } + default { + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" + } + } + } + literal { + #slash_active always false + #terminate the literal + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + literalpart { + #ended by ''' - but final could be '''' or ''''' (up to 2 squotes allowed directly before ending triple squote sequence) + #todo + # idea: end this literalpart (possibly 'temporarily') + # let the sq be reprocessed in the multiliteral-space to push an end-multiliteral-sequence to state stack + # upon popping end-multiliteral-sequence - stitch quotes back into this literalpart's token (if either too short - or a long ending sequence as shown above) + incr i -1 ;#throw the "'" back to loop - will be added to an squote_seq token for later processing + return 1 + } + XXXitablesquotedkey { + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + squotedkey { + ### + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + starttablename - starttablearrayname { + #!!! + incr i -1 + return 1 + } + tablename - tablearrayname { + append tok $c + } + barekey { + #not clear why o'shennanigan shouldn't be a legal barekey - but it seems not to be. + error "tomlish Unexpected single quote during barekey. [tomlish::parse::report_line]" + } + default { + append tok $c + } + } + } else { + switch -exact -- $state { + value-expected - array-space { + set_tokenType "_start_squote_sequence" + set tok "'" + } + itable-keyval-value-expected - keyval-value-expected { + set_tokenType "squote_seq_begin" + set tok "'" + return 1 + } + table-space { + #tests: squotedkey.test + set_tokenType "squotedkey" + set tok "" + } + itable-space { + #tests: squotedkey_itable.test + set_tokenType "squotedkey" + set tok "" + } + XXXitable-space { + #future - could there be multiline keys? + #this would allow arbitrary tcl dicts to be stored in toml + #probably unlikely - as it's perhaps not very 'minimal' or ergonomic for config files + set_tokenType "squote_seq_begin" + set tok "'" + return 1 + } + tablename-state { + #first char in tablename-state/tablearrayname-state + set_tokenType tablename + append tok "'" + } + tablearrayname-state { + set_tokenType tablearrayname + append tok "'" + } + literal-state { + tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?" + set_tokenType literal + incr -1 + return 1 + } + multistring-space { + error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" + } + multiliteral-space { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up an squote_seq to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "squote_seq_begin" + set tok "'" + return 1 + } + dottedkey-space { + set_tokenType squotedkey + } + default { + error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" + } + } + } + + } + dq { + #double quote + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + set toklen [tcl::string::length $tok] + if {$toklen == 1} { + append tok $c + } elseif {$toklen == 2} { + append tok $c + #switch vs set? + set_tokenType "startmultiquote" + return 1 + } else { + error "tomlish unexpected token length $toklen in 'startquotesequence'" + } + } + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + set_tokenType "startsquote" + incr i -1 + return 1 + } + 2 { + set_tokenType "startsquote" + incr i -2 + return 1 + } + default { + error "tomlish unexpected _start_squote_sequence length $toklen" + } + } + } + literal - literalpart { + append tok $c + } + string { + if {$had_slash} { + append tok "\\" $c + } else { + #unescaped quote always terminates a string? + set_token_waiting type endquote value "\"" complete 1 startindex $cindex + return 1 + } + } + stringpart { + #sub element of multistring + if {$had_slash} { + append tok "\\" $c + } else { + #incr i -1 + + if {$multi_dquote eq "\"\""} { + set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex -2}] + set multi_dquote "" + return 1 + } else { + append multi_dquote "\"" + } + } + } + whitespace { + switch -exact -- $state { + multistring-space { + #REVIEW + if {$had_slash} { + incr i -2 + return 1 + } else { + switch -- [tcl::string::length $multi_dquote] { + 2 { + set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex-2}] + set multi_dquote "" + return 1 + } + 1 { + incr i -2 + return 1 + } + 0 { + incr i -1 + return 1 + } + } + } + } + keyval-value-expected - value-expected { + #end whitespace token and reprocess + incr i -1 + return 1 + + #if {$multi_dquote eq "\"\""} { + # set_token_waiting type startmultiquote value "\"\"\"" complete 1 + # set multi_dquote "" + # return 1 + #} else { + # #end whitespace token and reprocess + # incr i -1 + # return 1 + #} + } + table-space - itable-space { + incr i -1 + return 1 + } + default { + set_token_waiting type startquote value "\"" complete 1 startindex $cindex + return 1 + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + XXXdquotedkey - XXXitablequotedkey { + if {$had_slash} { + append tok "\\" + append tok $c + } else { + set_token_waiting type endquote value "\"" complete 1 startindex $cindex + return 1 + } + } + dquotedkey { + ### + if {$had_slash} { + append tok "\\" + append tok $c + } else { + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + } + squotedkey { + append tok $c + } + tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + incr i -1 ;## + return 1 + } + default { + error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + #$slash_active not relevant when no tokenType + #token is string only if we're expecting a value at this point + switch -exact -- $state { + keyval-value-expected - value-expected - array-space { + #!? start looking for possible multistartquote + #set_tokenType startquote + #set tok $c + #return 1 + set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote + set tok $c + } + itable-keyval-value-expected { + #JMN 2025 - review + set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote + set tok $c + } + multistring-space { + #TODO - had_slash!!! + #REVIEW + if {$had_slash} { + set_tokenType "stringpart" + set tok "\\\"" + set multi_dquote "" + } else { + if {$multi_dquote eq "\"\""} { + tomlish::log::debug "- tokloop char dq ---> endmultiquote" + set_tokenType "endmultiquote" + set tok "\"\"\"" + return 1 + #set_token_waiting type endmultiquote value "\"\"\"" complete 1 + #set multi_dquote "" + #return 1 + } else { + append multi_dquote "\"" + } + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\"" + } + XXXtable-space { + set_tokenType "startquote" + set tok $c + return 1 + } + XXXitable-space { + set_tokenType "startquote" + set tok $c + } + table-space - itable-space { + set_tokenType "dquotedkey" + set tok "" + } + tablename-state { + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + dottedkey-space { + set_tokenType dquotedkey + set tok "" + + #only if complex keys become a thing + #set_tokenType dquote_seq_begin + #set tok $c + } + default { + error "tomlish Unexpected quote during state '$state' [tomlish::parse::report_line]" + } + } + } + } + = { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + #assertion had_slash 0, multi_dquote "" + append tok $c + } + string - comment - dquotedkey - itablequotedkey { + #for these tokenTypes an = is just data. + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + whitespace { + if {$state eq "multistring-space"} { + set backlen [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backlen + return 1 + } else { + set_token_waiting type equal value = complete 1 startindex $cindex + return 1 + } + } + barekey { + #set_token_waiting type equal value = complete 1 + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out + append tok $c + } + default { + error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok ${dquotes}= + } + multiliteral-space { + set_tokenType "literalpart" + set tok "=" + } + dottedkey-space { + set_tokenType "equal" + set tok "=" + return 1 + } + default { + set_tokenType "equal" + set tok = + return 1 + } + } + } + } + cr { + #REVIEW! + set dquotes $multi_dquote + set multi_dquote "" ;#!! + # \r carriage return + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #we have received a double cr + ::tomlish::log::warn "double cr - will generate cr token. needs testing" + set_tokenType "cr" ;#lone cr token will generally raise an error - but let state machine handle it + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal { + append tok $c + } + literalpart { + #part of MLL string (multi-line literal string) + #we need to split out crlf as a separate NEWLINE to be consistent + ::tomlish::log::warn "literalpart ended by cr - needs testing" + #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space + incr i -1 + return 1 + } + stringpart { + #stringpart is a part of MLB string (multi-line basic string) + #throw back the cr - if followed by lf it will become a {NEWLINE crlf} entry within the MULTISTRING list (e.g between STRINGPART entries) + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #could in theory be valid in quoted part of name + #review - might be better just to disallow here + append tok $c + } + whitespace { + #it should technically be part of whitespace if not followed by lf + #but outside of values we are also free to map it to be another NEWLINE instead? REVIEW + incr i -1 + return 1 + } + untyped_value { + incr i -1 + return 1 + } + default { + #!todo - error out if cr inappropriate for tokenType + append tok $c + } + } + } else { + #lf may be appended if next + #review - lone cr as newline? - this is uncommon - but so is lone cr in a string(?) + set_tokenType "newline" + set tok cr + } + } + lf { + # \n newline + set dquotes $multi_dquote + set multi_dquote "" ;#!! + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #review + #this lf is the trailing part of a crlf + append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal { + #nl is not allowed *within* a literal - require multiliteral syntax for any literal containing a newline ''' ''' + #even though we terminate the literal without the closing quote here - the token_waiting newline should trigger a state error + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + literalpart { + #we allow newlines - but store them within the multiliteral as their own element + #This is a legitimate end to the literalpart - but not the whole multiliteral + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + stringpart { + if {$dquotes ne ""} { + append tok $dquotes + incr i -1 + return 1 + } else { + if {$had_slash} { + #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) + set_token_waiting type continuation value \\ complete 1 startindex [expr {$cindex-1}] + incr i -1 + return 1 + } else { + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } + starttablename - tablename - tablearrayname - starttablearrayname { + error "tomlish Character is invalid in $tokenType. [tomlish::parse::report_line]" + } + default { + #newline ends all other tokens. + #note for string: we don't add (raw unescaped) newline to simple string. (must use multi-string for this) + #note for whitespace: + # we will use the convention that \n terminates the current whitespace even if whitespace follows + # ie whitespace is split into separate whitespace tokens at each newline + + #puts "-------------- newline lf during tokenType $tokenType" + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + if {$dquotes ne ""} { + #e.g one or 2 quotes just before nl + set_tokenType "stringpart" + set tok $dquotes + incr i -1 + return 1 + } + set_tokenType "newline" + set tok lf + return 1 + } + } + multiliteral-space { + #assert had_slash 0, multi_dquote "" + set_tokenType "newline" + set tok "lf" + return 1 + } + default { + #ignore slash? error? + set_tokenType "newline" + set tok lf + return 1 + } + } + #if {$had_slash} { + # #CONT directly before newline - allows strings_5_byteequivalent test to pass + # set_tokenType "continuation" + # set tok "\\" + # incr i -1 + # return 1 + #} else { + # set_tokenType newline + # set tok lf + # return 1 + #} + } + } + , { + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + comment - tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok , + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + #stringpart can have up to 2 quotes too + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + literal - literalpart - squotedkey { + #assert had_slash always 0, multi_dquote "" + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + set backlen [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backlen + return 1 + } else { + set_token_waiting type comma value "," complete 1 startindex $cindex + return 1 + } + } + default { + set_token_waiting type comma value "," complete 1 startindex $cindex + if {$had_slash} {append tok "\\"} + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "$dquotes," + } + multiliteral-space { + #assert had_slash 0, multi_dquote "" + set_tokenType "literalpart" + set tok "," + } + default { + set_tokenType "comma" + set tok "," + return 1 + } + } + } + } + . { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + comment - untyped_value { + if {$had_slash} {append tok "\\"} + append tok $c + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + literal - literalpart - squotedkey { + #assert had_slash always 0, multi_dquote "" + append tok $c + } + whitespace { + switch -exact -- $state { + multistring-space { + set backchars [expr {[tcl::string::length $dquotes] + 1}] + if {$had_slash} { + incr backchars 1 + } + incr i -$backchars + return 1 + } + xxxdottedkey-space { + incr i -1 + return 1 + } + dottedkey-space-tail { + incr i -1 + return 1 + } + default { + error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" + } + } + } + starttablename - starttablearrayname { + #This would correspond to an empty table name + error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #subtable - split later - review + append tok $c + } + barekey { + #e.g x.y = 1 + #we need to transition the barekey to become a structured table name ??? review + #x is the tablename y is the key + set_token_waiting type dotsep value "." complete 1 startindex $cindex + return 1 + } + default { + error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" + #set_token_waiting type period value . complete 1 + #return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "$dquotes." + } + multiliteral-space { + set_tokenType "literalpart" + set tok "." + } + XXXdottedkey-space { + ### obs? + set_tokenType "dotsep" + set tok "." + return 1 + } + dottedkey-space-tail { + ### + set_tokenType "dotsep" + set tok "." + return 1 + } + default { + set_tokenType "untyped_value" + set tok "." + } + } + } + + } + " " { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + if {[tcl::string::length $tokenType]} { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + barekey { + #todo had_slash - emit token or error + #whitespace is a terminator for bare keys + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + comment { + if {$had_slash} { + append tok "\\" + } + append tok $dquotes$c + } + string - dquotedkey - itablequotedkey { + if {$had_slash} { append tok "\\" } + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + append tok $dquotes + incr i -1 + return 1 + } + } + literal - literalpart - squotedkey { + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + if {$dquotes ne ""} { + #end whitespace token + #go back by the number of quotes plus this space char + set backchars [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backchars + return 1 + } else { + append tok $c + } + } else { + append tok $c + } + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + if {$dquotes ne ""} { + set_tokenType "stringpart" + set tok $dquotes + incr i -1 + return 1 + } + set_tokenType "whitespace" + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + if {$had_slash} { + error "tomlish unexpected backslash [tomlish::parse::report_line]" + } + set_tokenType "whitespace" + append tok $c + } + } + } + } + tab { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out (?review) + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + barekey { + #whitespace is a terminator for bare keys + incr i -1 + #set_token_waiting type whitespace value $c complete 1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + squotedkey { + append tok $c + } + dquotedkey - string - comment - whitespace { + #REVIEW + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + append tok $dquotes + incr i -1 + return 1 + } + } + literal - literalpart { + append tok $c + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearraynames { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + if {$slash_active} { + set slash_active 0 + } + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + if {$dquotes ne ""} { + set_tokenType stringpart + set tok $dquotes + incr i -1 + return 1 + } else { + set_tokenType whitespace + append tok $c + } + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "whitespace" + append tok $c + } + } + } + } + bom { + #BOM (Byte Order Mark) - ignored by token consumer + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + _start_squote_sequence { + #assert - tok will be one or two squotes only + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart { + append tok $c + } + default { + set_token_waiting type bom value "\uFEFF" complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "bom" + set tok "\uFEFF" + return 1 + } + } + } + } + default { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + if {$dquotes ne ""} { + set backlen [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backlen + return 1 + } else { + incr i -1 + return 1 + } + } else { + #review + incr i -1 ;#We don't have a full token to add to the token_waiting dict - so leave this char for next run. + return 1 + } + } + barekey { + if {[tomlish::utils::is_barekey $c]} { + append tok $c + } else { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" + } + } + starttablename - starttablearrayname { + incr i -1 + #allow statemachine to set context for subsequent chars + return 1 + } + stringpart { + append tok $dquotes$c + } + default { + #e.g comment/string/literal/literalpart/untyped_value/starttablename/starttablearrayname/tablename/tablearrayname + append tok $c + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + table-space - itable-space { + #if no currently active token - assume another key value pair + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + XXXcurly-syntax { + puts stderr "curly-syntax - review" + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + multistring-space { + set_tokenType "stringpart" + if {$had_slash} { + #assert - we don't get had_slash and dquotes at same time + set tok \\$c + } else { + set tok $dquotes$c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + tablename-state { + set_tokenType "tablename" + set tok $c + } + tablearrayname-state { + set_tokenType "tablearrayname" + set tok $c + } + dottedkey-space { + set_tokenType barekey + set tok $c + } + default { + #todo - something like ansistring VIEW to show control chars? + set cshow [string map [list \t tab \v vt] $c] + tomlish::log::debug "- tokloop char '$cshow' setting to untyped_value while state:$state [tomlish::parse::report_line]" + set_tokenType "untyped_value" + set tok $c + } + } + } + } + } + + } + + #run out of characters (eof) + if {[tcl::string::length $tokenType]} { + #check for invalid ending tokens + #if {$state eq "err-state"} { + # error "Reached end of data whilst tokenType = '$tokenType'. INVALID" + #} + switch -exact -- $tokenType { + startquotesequence { + set toklen [tcl::string::length $tok] + if {$toklen == 1} { + #invalid + #eof with open string + error "tomlish eof reached without closing quote for string. [tomlish::parse::report_line]" + } elseif {$toklen == 2} { + #valid + #we ended in a double quote, not actually a startquoteseqence - effectively an empty string + switch_tokenType "startquote" + incr i -1 + #set_token_waiting type string value "" complete 1 + return 1 + } + } + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open literal + error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" + } + 2 { + #review + set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] + set_tokenType "literal" + set tok "" + return 1 + } + } + } + newline { + #The only newline token that has still not been returned should have a tok value of "cr" + puts "tomlish eof reached - with incomplete newline token '$tok'" + if {$tok eq "cr"} { + #we convert lone cr to it's own "cr" token elsewhere in the document to allow statemachine to handle it. + #(which it should generally do by not handling it ie raising an error - or emitting an ERROR list in the tomlish) + #if trailing char is a lone cr - we should encode it the same way as elsewhere that is outside of values + # ie as it's own token. + switch_tokenType "cr" + return 1 + } else { + #should be unreachable + error "tomlish eof reached - with invalid newline token. value: $tok" + } + } + } + set_token_waiting type eof value eof complete 1 startindex $i ;#review + return 1 + } else { + ::tomlish::log::debug "- No current tokenType, ran out of characters, setting tokenType to 'eof' [tomlish::parse::report_line]" + set tokenType "eof" + set tok "eof" + } + return 0 + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::parse ---}] +} + +namespace eval tomlish::dict { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} + } + proc is_tomlish_typeval2 {d} { + upvar ::tomlish::tags tags + expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} + } + proc last_tomltype_posn {d} { + set last_simple -1 + set dictposn [expr {[dict size $d] -1}] + foreach k [lreverse [dict keys $d]] { + set dval [dict get $d $k] + if {[is_tomlish_typeval $dval]} { + set last_simple $dictposn + break + } + incr dictposn -1 + } + return $last_simple + } + + + #review + proc name_from_tablestack {tablestack} { + set name "" + foreach tinfo [lrange $tablestack 1 end] { + lassign $tinfo type namepart + switch -- $type { + T { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + I { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + default { + #end at first break in the leading sequence of T & I tablenames + break + } + } + } + return $name + } + +} + +tcl::namespace::eval tomlish::app { + variable applist [list encoder decoder test] + + #*** !doctools + #[subsection {Namespace tomlish::app}] + #[para] + #[list_begin definitions] + + proc decoder {args} { + #*** !doctools + #[call app::[fun decoder] [arg args]] + #[para] read toml on stdin until EOF + #[para] on error - returns non-zero exit code and writes error on stderr + #[para] on success - returns zero exit code and writes JSON encoding of the data on stdout + #[para] This decoder is intended to be compatible with toml-test + + set opts [dict merge [dict create] $args] + #fconfigure stdin -encoding utf-8 + fconfigure stdin -translation binary + #Just slurp it all - presumably we are not handling massive amounts of data on stdin. + # - even if the input is large, we probably don't gain much (aside from possible memory savings?) by attempting to process input as it arrives. + if {[catch { + set toml [read stdin] + }]} { + exit 2 ;#read error + } + try { + set j [::tomlish::toml_to_json $toml] + } on error {em} { + puts stderr "decoding failed: '$em'" + exit 1 + } + puts -nonewline stdout $j + exit 0 + } + + proc encoder {args} { + #*** !doctools + #[call app::[fun encoder] [arg args]] + #[para] read JSON on stdin until EOF + #[para] return non-zero exitcode if JSON data cannot be converted to a valid TOML representation + #[para] return zero exitcode and TOML data on stdout if JSON data can be converted. + #[para] This encoder is intended to be compatible with toml-test + + set opts [dict merge [dict create] $args] + fconfigure stdin -translation binary + if {[catch { + set json [read stdin] + }]} { + exit 2 ;#read error + } + try { + set toml [::tomlish::json_to_toml $json] + } on error {em} { + puts stderr "encoding failed: '$em'" + exit 1 + } + puts -nonewline stdout $toml + exit 0 + } + + proc test {args} { + set opts [dict merge [dict create] $args] + + package require test::tomlish + if {[dict exists $opts -suite]} { + test::tomlish::suite [dict get $opts -suite] + } + test::tomlish::run + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::app ---}] +} + +proc ::tomlish::appnames {} { + set applist [list] + foreach cmd [info commands ::tomlish::app::*] { + lappend applist [namespace tail $cmd] + } + return $applist +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace tomlish::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 tomlish::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +if {$argc > 0} { + puts stderr "argc: $argc args: $argv" + + if {($argc == 1)} { + if {[tcl::string::tolower $argv] in {help -help h -h}} { + puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + exit 0 + } else { + puts stderr "Argument '$argv' not understood. Try -help" + exit 1 + } + } + set opts [dict create] + set opts [dict merge $opts $argv] + + set opts_understood [list -app ] + if {"-app" in [dict keys $opts]} { + #Don't vet the remaining opts - as they are interpreted by each app + } else { + foreach key [dict keys $opts] { + if {$key ni $opts_understood} { + puts stderr "Option '$key' not understood" + exit 1 + } + } + } + if {[dict exists $opts -app]} { + set app [dict get $opts -app] + if {$app ni [tomlish::appnames]} { + puts stderr "app '[dict get $opts -app]' not found" + exit 1 + } + tomlish::app::$app {*}$opts + } +} + +## Ready +package provide tomlish [namespace eval tomlish { + variable pkg tomlish + variable version + set version 1.1.3 +}] +return + +#*** !doctools +#[manpage_end] + 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 6776eb79..775335c3 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 @@ -2,12 +2,15 @@ # # punkboot - make any tclkits and modules in /src folders and place them and associated data files/scripts in the parent folder of src. #e.g in 'bin' and 'modules' folders at same level as 'src' folder. +if {[info exists ::env(NO_COLOR)]} { + namespace eval ::punk::console {variable colour_disabled 1} +} set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" puts $hashline -puts " Punk Boot" +puts " Punk Boot" puts $hashline\n -package prefer latest +package prefer latest lassign [split [info tclversion] .] tclmajorv tclminorv global A ;#UI Ansi code array @@ -104,7 +107,7 @@ namespace eval ::punkboot::lib { } } return [join $newparts .] - } + } proc tm_version_required_canonical {versionspec} { #also trim leading zero from any dottedpart? #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. @@ -112,10 +115,10 @@ namespace eval ::punkboot::lib { #also 1b3 == 1b0003 if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version - set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification" + set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification" if {[string first - $versionspec] < 0} { - #no dash - #looks like a minbounded version (ie a single version with no dash) convert to min-max form + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form set from $versionspec if {![::punkboot::lib::tm_version_isvalid $from]} { error "$errmsg '$versionpec'" @@ -127,7 +130,7 @@ namespace eval ::punkboot::lib { error "$errmsg '$versionspec'" } } else { - # min- or min-max + # min- or min-max #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) set parts [split $versionspec -] ;#we expect only 2 parts lassign $parts from to @@ -162,18 +165,18 @@ if {"::try" ni [info commands ::try]} { #------------------------------------------------------------------------------ #Module loading from src/bootsupport or [pwd]/modules if pwd is a 'src' folder #------------------------------------------------------------------------------ -#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files +#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files # - then it will attempt to preference these modules # This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the boot script # and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables set startdir [pwd] #we are focussed on pure-tcl libs/modules in bootsupport for now. -#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc +#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc #REVIEW - punkboot can really speed up with appropriate accelerators and/or external binaries # - we need to support that without binary downloads from repos unless the user explicitly asks for that. # - They may already be available in the vfs (or pointed to package paths) of the running executable. # - todo: some user prompting regarding installs with platform-appropriate package managers -# - todo: some user prompting regarding building accelerators from source. +# - todo: some user prompting regarding building accelerators from source. # ------------------------------------------------------------------------------------- set bootsupport_module_paths [list] @@ -209,7 +212,7 @@ if {[file tail $startdir] eq "src"} { #todo - other src 'module' dirs.. foreach p [list $startdir/modules $startdir/modules_tcl$::tclmajorv $startdir/vendormodules $startdir/vendormodules_tcl$::tclmajorv] { if {[file exists $p]} { - lappend sourcesupport_module_paths $p + lappend sourcesupport_module_paths $p } } # -- -- -- @@ -219,7 +222,7 @@ if {[file tail $startdir] eq "src"} { } } # -- -- -- - + foreach p [list {*}$sourcesupport_module_paths {*}$sourcesupport_library_paths] { if {[file exists $p]} { set sourcesupport_paths_exist 1 @@ -228,7 +231,7 @@ if {[file tail $startdir] eq "src"} { } if {$sourcesupport_paths_exist} { - #launch from auto_path $::auto_path" @@ -281,18 +284,19 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { #package require Thread # - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly. - - + # tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list - #These are strong dependencies + #These are strong dependencies package forget punk::mix - package forget punk::repo - package forget punkcheck + package forget punk::repo + package forget punkcheck package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies package require punk::mix package require punkcheck package require punk::lib + package require punk::args + package require punk::ansi set package_paths_modified 1 @@ -302,11 +306,12 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { set ::punkboot::pkg_requirements_found [list] #we will treat 'package require .' (minbounded) as .- ie explicitly convert to corresponding bounded form -#put some with leading zeros to test normalisation +#put some with leading zeros to test normalisation set ::punkboot::bootsupport_requirements [dict create\ punk::repo [list version "00.01.01-"]\ punk::mix [list version ""]\ punk::ansi [list]\ + punk::args [list]\ overtype [list version "1.6.5-"]\ punkcheck [list]\ fauxlink [list version "0.1.1-"]\ @@ -322,7 +327,7 @@ dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { if {![catch {::punkboot::lib::tm_version_required_canonical $ver} canonical]} { if {$canonical ne $ver} { dict set pkginfo version $canonical ;# plain ver mapped to min-max. min- and min-max and empty left as is - dict set ::punkboot::bootsupport_requirements $pkg $pkginfo + dict set ::punkboot::bootsupport_requirements $pkg $pkginfo } } else { puts stderr "punkboot::bootsupport_requirements - package $pkg has invalid version specification '$ver'" @@ -331,9 +336,9 @@ dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { } else { #make sure each has a blank version entry if nothing was there. dict set pkginfo version "" - dict set ::punkboot::bootsupport_requirements $pkg $pkginfo + dict set ::punkboot::bootsupport_requirements $pkg $pkginfo } -} +} #Assert - our bootsupport_requirement version numbers should now be either empty or of the form min- or min-max #dict for {k v} $::punkboot::bootsupport_requirements { # puts "- $k $v" @@ -356,7 +361,7 @@ set ::punkboot::bootsupport_recommended [dict create\ # create an interp in which we hijack package command # This allows us to auto-gather some dependencies (not necessarily all and not necessarily strictly required) # Note: even in a separate interp we could still possibly get side-effects if a package has compiled components - REVIEW -# Hopefully the only side-effect is that a subsequent load of the package will be faster... +# Hopefully the only side-effect is that a subsequent load of the package will be faster... # (punk boot is intended to operate without compiled components - but some could be pulled in by tcl modules if they're found) # (tcllibc is also highly desirable as the performance impact when not available can be dramatic.) # ... but if the binary is loaded with a different path name when we come to actually use it - there could be issues. @@ -378,7 +383,7 @@ proc ::punkboot::check_package_availability {args} { #best effort at auto-determinining packages required (dependencies) based on top-level packages in the list. #Without fully parsing the package-loading Tcl scripts and examining all side-effects (an unlikely capability), # this is not going to be as accurate as the package developer providing a definitive list of which packages are required and which are optional. - # 'optionality' is a contextual concept anyway depending on how the package is intended to be used. + # 'optionality' is a contextual concept anyway depending on how the package is intended to be used. # The package developer may consider a feature optional - but it may not be optional in a particular usecase. set bootsupport_requirements [lindex $args end] @@ -484,7 +489,7 @@ proc ::punkboot::check_package_availability {args} { #should still distinguish: {pkgname {}} -valid vs {pkgname {{}}} due to empty string supplied in call - invalid - but leave for underlying package command to error on set pkgrequest [list $pkgname $requirements_list] if {$pkgrequest ni $::test::pkg_requested} { - lappend ::test::pkg_requested $pkgrequest + lappend ::test::pkg_requested $pkgrequest } # -- -- --- --- --- --- --- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -507,13 +512,13 @@ proc ::punkboot::check_package_availability {args} { } if {[llength $::test::pkg_stack]} { set caller [lindex $::test::pkg_stack end] - set required_by [dict get $pinfo required_by] + set required_by [dict get $pinfo required_by] if {$caller ni $required_by} { lappend required_by $caller } dict set pinfo required_by $required_by } - lappend ::test::pkg_stack $pkgname + lappend ::test::pkg_stack $pkgname #At this point we could short circuit if we've already classified this package/requirements combo as missing/broken from a previous require #review - there is some chance the exact pkg/requirements combo may succeed after an earlier failure if some package adjusted search paths.. @@ -527,23 +532,23 @@ proc ::punkboot::check_package_availability {args} { #use our normalised requirements instead of original args #if {[catch [list ::package_orig {*}$args] result]} {} if {[catch [list ::package_orig require $pkgname {*}$requirements_list] result]} { - dict set pinfo testerror $result + dict set pinfo testerror $result #package missing - or exists - but failing to initialise if {!$::opt_quiet} { set parent_path [lrange $::test::pkg_stack 0 end-1] puts stderr "\x1b\[32m $pkgname versions: $versions error: $result\x1b\[m" set parent_path [join $parent_path " -> "] - puts stderr "pkg requirements: $parent_path" + puts stderr "pkg requirements: $parent_path" puts stderr "error during : '$args'" puts stderr " \x1b\[93m$result\x1b\[m" } #the failed package may still exist - so we could check 'package files' and 'package ifneeded' here too - REVIEW - #to determine the version that we attempted to load, + #to determine the version that we attempted to load, #- we need to look at 'pkg versions' vs -exact / ver / ver-ver (using package vsatisfies) if {![llength $versions]} { #no versions *and* we had an error - missing is our best guess. review. - #'package versions Tcl' never shows any results + #'package versions Tcl' never shows any results #so requests for old versions will show as missing not broken. #This is probably better anyway. if {$pkgrequest ni $::test::pkg_missing} { @@ -572,21 +577,21 @@ proc ::punkboot::check_package_availability {args} { lappend selectable_versions $v } } else { - #we are operating under 'package prefer' = latest + #we are operating under 'package prefer' = latest set selectable_versions $ordered_versions } if {[llength $requirements_list]} { #add one or no entry for each requirement. #pick highest at end - set satisfiers [list] + set satisfiers [list] foreach requirement $requirements_list { foreach ver [lreverse $selectable_versions] { if {[package vsatisfies $ver $requirement]} { lappend satisfiers $ver break - } - } + } + } } if {[llength $satisfiers]} { set satisfiers [lsort -command {::package_orig vcompare} $satisfiers] @@ -622,7 +627,7 @@ proc ::punkboot::check_package_availability {args} { if {![catch {::package_orig files Tcl} ]} { #tcl9 (also some 8.6/8.7) has 'package files' subcommand. #unfortunately, in some cases (e.g md5 when no accelerators available) this can be a huge list (1000+) showing all scanned pkgIndex.tcl files from unrelated packages. - #We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour + #We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour #see: https://core.tcl-lang.org/tcl/tktview/209fd9adce set all_files [::package_orig files $pkgname] #some arbitrary threshold? REVIEW @@ -637,7 +642,7 @@ proc ::punkboot::check_package_availability {args} { dict set pinfo packagefiles {} ;#default #there are all sorts of scripts, so this is not predictably structured #e.g using things like apply - #we will attempt to get a trailing source .. + #we will attempt to get a trailing source .. set parts [split [string trim $ifneeded_script] {;}] set trimparts [list] foreach p $parts { @@ -648,7 +653,7 @@ proc ::punkboot::check_package_availability {args} { if {$last_with_text ne "" && [regexp -- {\S+$} $last_with_text lastword]} { #if it's a file or dir - close enough (?) #e.g tcllibc uses apply and the last entry is actuall a folder used to find the file.. - #we aren't brave enough to try to work out the actual file(s) + #we aren't brave enough to try to work out the actual file(s) if {[file exists $lastword]} { dict set pinfo packagefiles $lastword } @@ -662,10 +667,10 @@ proc ::punkboot::check_package_availability {args} { return [uplevel 1 [list ::package_orig {*}$args]] } } - + set ::test::pkg_stack [list] catch {::package_orig require zzz-non-existant} ;#scan so we get 'package versions' results - dict for {pkg pkgdict} $::test::bootsupport_requirements { + dict for {pkg pkgdict} $::test::bootsupport_requirements { #set nsquals [namespace qualifiers $pkg] #if {$nsquals ne ""} { # catch {::package_orig require ${nsquals}::zzz-non-existant} ;#force scan of every level encountered @@ -690,7 +695,7 @@ proc ::punkboot::check_package_availability {args} { # set ver [package provide $pkg] # if {$ver eq ""} { # #puts stderr "missing pkg: $pkg" - # lappend ::test::pkg_missing $pkg + # lappend ::test::pkg_missing $pkg # } else { # if {[string tolower $pkg] eq "tcl"} { # #ignore @@ -1180,17 +1185,17 @@ if {$::punkboot::command eq "check"} { puts stdout "- tcl::tm::list" foreach fld [tcl::tm::list] { if {[file exists $fld]} { - puts stdout " $fld" + puts stdout " $fld" } else { - puts stdout " $fld (not present)" + puts stdout " $fld (not present)" } } puts stdout "- auto_path" foreach fld $::auto_path { if {[file exists $fld]} { - puts stdout " $fld" + puts stdout " $fld" } else { - puts stdout " $fld (not present)" + puts stdout " $fld (not present)" } } flush stdout @@ -1283,22 +1288,22 @@ if {$::punkboot::command eq "info"} { set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] puts stdout "- vendorlib folders: ([llength $vendorlibfolders])" foreach fld $vendorlibfolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } puts stdout "- vendormodule folders: ([llength $vendormodulefolders])" foreach fld $vendormodulefolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] puts stdout "- source module paths: [llength $source_module_folderlist]" foreach fld $source_module_folderlist { - puts stdout " $fld" + puts stdout " $fld" } set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] lappend projectlibfolders lib puts stdout "- source libary paths: [llength $projectlibfolders]" foreach fld $projectlibfolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { set vc "fossil" @@ -1389,10 +1394,9 @@ if {$::punkboot::command eq "vendorupdate"} { #todo vendor/lib set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] - set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] - lappend vendormodulefolders vendormodules + set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] + #lappend vendormodulefolders vendormodules foreach vf $vendormodulefolders { - if {[file exists $sourcefolder/$vf]} { lassign [split $vf _] _vm tclx if {$tclx ne ""} { set which _$tclx @@ -1481,7 +1485,6 @@ if {$::punkboot::command eq "vendorupdate"} { } else { puts stderr "No config at $vendor_config - nothing configured to update" } - } } } @@ -1508,105 +1511,102 @@ if {$::punkboot::command eq "bootsupport"} { set bootsupport_modules [list] ;#variable populated by include_modules.config file - review set sourcefolder $projectroot/src - set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules_tcl*] - lappend bootmodulefolders modules + set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules modules_tcl*] foreach bm $bootmodulefolders { - if {[file exists $sourcefolder/bootsupport/$bm]} { - lassign [split $bm _] _bm tclx - if {$tclx ne ""} { - set which _$tclx + lassign [split $bm _] _bm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# + if {[file exists $bootsupport_config]} { + set targetroot $projectroot/src/bootsupport/modules$which + source $bootsupport_config ;#populate $bootsupport_modules with project-specific list + if {![llength $bootsupport_modules]} { + puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" } else { - set which "" - } - set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# - if {[file exists $bootsupport_config]} { - set targetroot $projectroot/src/bootsupport/modules$which - source $bootsupport_config ;#populate $bootsupport_modules with project-specific list - if {![llength $bootsupport_modules]} { - puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" - } else { - if {[catch { - #---------- - set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] - $boot_installer set_source_target $projectroot $projectroot/src/bootsupport - set boot_event [$boot_installer start_event {-make_step bootsupport}] - #---------- - } errM]} { - puts stderr "Unable to use punkcheck for bootsupport error: $errM" - set boot_event "" - } + if {[catch { + #---------- + set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] + $boot_installer set_source_target $projectroot $projectroot/src/bootsupport + set boot_event [$boot_installer start_event {-make_step bootsupport}] + #---------- + } errM]} { + puts stderr "Unable to use punkcheck for bootsupport error: $errM" + set boot_event "" + } - foreach {relpath modulematch} $bootsupport_modules { - set modulematch [string trim $modulematch :] - set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]] - set srclocation [file join $projectroot $relpath $module_subpath] - #puts stdout "$relpath $modulematch $module_subpath $srclocation" - if {[string first - $modulematch]} { - set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm] - } else { - set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm] - } - if {![llength $pkgmatches]} { - puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation" - continue - } + foreach {relpath modulematch} $bootsupport_modules { + set modulematch [string trim $modulematch :] + set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $modulematch $module_subpath $srclocation" + if {[string first - $modulematch]} { + set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm] + } else { + set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm] + } + if {![llength $pkgmatches]} { + puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation" + continue + } - set modulematch_is_glob [regexp {[*?\[\]]} $modulematch] - if {!$modulematch_is_glob} { - #if modulematch was specified without globs - only copy latest - #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func - set pkgmatches [lsort -command modfile_sort $pkgmatches] - set latestfile [lindex $pkgmatches end] - #set latestver [lindex [split [file rootname $latestfile] -] 1] - set copy_files $latestfile - } else { - #globs in modulematch - may be different packages matched by glob - copy all versions of matches - #review - set copy_files $pkgmatches - } - foreach cfile $copy_files { - set srcfile [file join $srclocation $cfile] - set tgtfile [file join $targetroot $module_subpath $cfile] - if {$boot_event ne ""} { - #---------- - $boot_event targetset_init INSTALL $tgtfile - $boot_event targetset_addsource $srcfile - #---------- - if {\ - [llength [dict get [$boot_event targetset_source_changes] changed]]\ - || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ - } { - file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists - $boot_event targetset_started - # -- --- --- --- --- --- - puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile" - if {[catch { - file copy -force $srcfile $tgtfile - } errM]} { - $boot_event targetset_end FAILED - } else { - $boot_event targetset_end OK - } - # -- --- --- --- --- --- + set modulematch_is_glob [regexp {[*?\[\]]} $modulematch] + if {!$modulematch_is_glob} { + #if modulematch was specified without globs - only copy latest + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func + set pkgmatches [lsort -command modfile_sort $pkgmatches] + set latestfile [lindex $pkgmatches end] + #set latestver [lindex [split [file rootname $latestfile] -] 1] + set copy_files $latestfile + } else { + #globs in modulematch - may be different packages matched by glob - copy all versions of matches + #review + set copy_files $pkgmatches + } + foreach cfile $copy_files { + set srcfile [file join $srclocation $cfile] + set tgtfile [file join $targetroot $module_subpath $cfile] + if {$boot_event ne ""} { + #---------- + $boot_event targetset_init INSTALL $tgtfile + $boot_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$boot_event targetset_source_changes] changed]]\ + || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ + } { + file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists + $boot_event targetset_started + # -- --- --- --- --- --- + puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $boot_event targetset_end FAILED } else { - puts -nonewline stderr "." - $boot_event targetset_end SKIPPED + $boot_event targetset_end OK } - $boot_event end + # -- --- --- --- --- --- } else { - file copy -force $srcfile $tgtfile + puts -nonewline stderr "." + $boot_event targetset_end SKIPPED } + $boot_event end + } else { + file copy -force $srcfile $tgtfile } } - if {$boot_event ne ""} { - puts \n - $boot_event destroy - $boot_installer destroy - } } - + if {$boot_event ne ""} { + puts \n + $boot_event destroy + $boot_installer destroy + } } + } } } @@ -1699,59 +1699,53 @@ if {$::punkboot::command ni {project modules vfs}} { #install src vendor contents (from version controlled src folder) to base of project (same target folders as our own src/modules etc ie to paths that go on the auto_path and in tcl::tm::list) if {$::punkboot::command in {project modules}} { - set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] - lappend vendorlibfolders vendorlib - foreach lf $vendorlibfolders { - if {[file exists $sourcefolder/$lf]} { - lassign [split $lf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_lib_folder $projectroot/lib$which - file mkdir $projectroot/lib$which - #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g - # */test.txt will only match test.txt exactly one level deep. - # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. - # **/test.txt will match at any level below the root (but not in the root) - set antipaths [list\ - README.md\ - ] - puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] - } - } - if {![llength $vendorlibfolders]} { - puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." - } - - set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] - lappend vendormodulefolders vendormodules - + set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] foreach vf $vendormodulefolders { - if {[file exists $sourcefolder/$vf]} { - lassign [split $vf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_module_folder $projectroot/modules$which - file mkdir $target_module_folder - - #install .tm *and other files* - puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] + lassign [split $vf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" } + set target_module_folder $projectroot/modules$which + file mkdir $target_module_folder + + #install .tm *and other files* + puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $vendormodulefolders]} { puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found." } + set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib vendorlib_tcl*] + foreach lf $vendorlibfolders { + lassign [split $lf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_lib_folder $projectroot/lib$which + file mkdir $projectroot/lib$which + #exclude README.md from source folder - but only the root one + #-antiglob_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) + set antipaths [list\ + README.md\ + ] + puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } + if {![llength $vendorlibfolders]} { + puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." + } + + ######################################################## #templates #e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync @@ -1760,10 +1754,10 @@ if {$::punkboot::command in {project modules}} { set old_layout_update_list [list\ [list project $sourcefolder/modules/punk/mix/templates]\ [list basic $sourcefolder/mixtemplates]\ - ] + ] set layout_bases [list\ $sourcefolder/project_layouts/custom/_project\ - ] + ] foreach layoutbase $layout_bases { if {![file exists $layoutbase]} { @@ -1823,27 +1817,25 @@ if {$::punkboot::command in {project modules}} { set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] lappend projectlibfolders lib foreach lf $projectlibfolders { - if {[file exists $sourcefolder/$lf]} { - lassign [split $lf _] _vm tclx - if {$tclx ne ""} { - set which _$tclx - } else { - set which "" - } - set target_lib_folder $projectroot/lib$which - file mkdir $projectroot/lib$which - #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g - # */test.txt will only match test.txt exactly one level deep. - # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. - # **/test.txt will match at any level below the root (but not in the root) - set antipaths [list\ - README.md\ - ] - puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] - } + lassign [split $lf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_lib_folder $projectroot/lib$which + file mkdir $projectroot/lib$which + #exclude README.md from source folder - but only the root one + #-antiglob_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) + set antipaths [list\ + README.md\ + ] + puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $projectlibfolders]} { puts stderr "PROJECTLIB: No src/lib or src/lib_tcl* folder found." @@ -2355,7 +2347,7 @@ foreach vfstail $vfs_tails { } else { lappend runtimes $matchrt } - } + } } #assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/argp-0.2.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/argp-0.2.tm new file mode 100644 index 00000000..1b1f4b78 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/argp-0.2.tm @@ -0,0 +1,259 @@ + +# Tcl parser for optional arguments in function calls and +# commandline arguments +# +# (c) 2001 Bastien Chevreux + +# Index of exported commands +# - argp::registerArgs +# - argp::setArgDefaults +# - argp::setArgsNeeded +# - argp::parseArgs + +# Internal commands +# - argp::CheckValues + +# See end of file for an example on how to use + +package provide argp 0.2 + +namespace eval argp { + variable Optstore + variable Opttypes { + boolean integer double string + } + + namespace export {[a-z]*} +} + + +proc argp::registerArgs { func arglist } { + variable Opttypes + variable Optstore + + set parentns [string range [uplevel 1 [list namespace current]] 2 end] + if { $parentns != "" } { + append caller $parentns :: $func + } else { + set caller $func + } + set cmangled [string map {:: _} $caller] + + #puts $parentns + #puts $caller + #puts $cmangled + + set Optstore(keys,$cmangled) {} + set Optstore(deflist,$cmangled) {} + set Optstore(argneeded,$cmangled) {} + + foreach arg $arglist { + foreach {opt type default allowed} $arg { + set optindex [lsearch -glob $Opttypes $type*] + if { $optindex < 0} { + return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]" + } + set type [lindex $Opttypes $optindex] + + lappend Optstore(keys,$cmangled) $opt + set Optstore(type,$opt,$cmangled) $type + set Optstore(default,$opt,$cmangled) $default + set Optstore(allowed,$opt,$cmangled) $allowed + lappend Optstore(deflist,$cmangled) $opt $default + } + } + + if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} { + return -code error "Error in declaration of optional arguments.\n$res" + } +} + +proc argp::setArgDefaults { func arglist } { + variable Optstore + + set parentns [string range [uplevel 1 [list namespace current]] 2 end] + if { $parentns != "" } { + append caller $parentns :: $func + } else { + set caller $func + } + set cmangled [string map {:: _} $caller] + + if {![info exists Optstore(deflist,$cmangled)]} { + return -code error "Arguments for $caller not registered yet." + } + set Optstore(deflist,$cmangled) {} + foreach {opt default} $arglist { + if {![info exists Optstore(default,$opt,$cmangled)]} { + return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" + } + set Optstore(default,$opt,$cmangled) $default + } + + # set the new defaultlist + foreach opt $Optstore(keys,$cmangled) { + lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled) + } +} + +proc argp::setArgsNeeded { func arglist } { + variable Optstore + + set parentns [string range [uplevel 1 [list namespace current]] 2 end] + if { $parentns != "" } { + append caller $parentns :: $func + } else { + set caller $func + } + set cmangled [string map {:: _} $caller] + + #append caller $parentns :: $func + #set cmangled ${parentns}_$func + + if {![info exists Optstore(deflist,$cmangled)]} { + return -code error "Arguments for $caller not registered yet." + } + + set Optstore(argneeded,$cmangled) {} + foreach opt $arglist { + if {![info exists Optstore(default,$opt,$cmangled)]} { + return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" + } + lappend Optstore(argneeded,$cmangled) $opt + } +} + + +proc argp::parseArgs { args } { + variable Optstore + + if {[llength $args] == 0} { + upvar args a opts o + } else { + upvar args a [lindex $args 0] o + } + + if { [ catch { set caller [lindex [info level -1] 0]}]} { + set caller "main program" + set cmangled "" + } else { + set cmangled [string map {:: _} $caller] + } + + if {![info exists Optstore(deflist,$cmangled)]} { + return -code error "Arguments for $caller not registered yet." + } + + # set the defaults + array set o $Optstore(deflist,$cmangled) + + # but unset the needed arguments + foreach key $Optstore(argneeded,$cmangled) { + catch { unset o($key) } + } + + foreach {key val} $a { + if {![info exists Optstore(type,$key,$cmangled)]} { + return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)" + } + switch -exact -- $Optstore(type,$key,$cmangled) { + boolean - + integer { + if { $val == "" } { + return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value." + } + if { ![string is $Optstore(type,$key,$cmangled) $val]} { + return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value." + } + } + double { + if { $val == "" } { + return -code error "$caller, $key empty string is not double value." + } + if { ![string is double $val]} { + return -code error "$caller, $key $val is not double value." + } + if { [string is integer $val]} { + set val [expr {$val + .0}] + } + } + default { + } + } + set o($key) $val + } + + foreach key $Optstore(argneeded,$cmangled) { + if {![info exists o($key)]} { + return -code error "$caller, needed argument $key was not given." + } + } + + if { [catch { CheckValues $caller $cmangled [array get o]} err]} { + return -code error $err + } + + return +} + + +proc argp::CheckValues { caller cmangled checklist } { + variable Optstore + + #puts "Checking $checklist" + + foreach {key val} $checklist { + if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } { + switch -exact -- $Optstore(type,$key,$cmangled) { + string { + if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} { + return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)" + } + } + double - + integer { + set found 0 + foreach range $Optstore(allowed,$key,$cmangled) { + if {[llength $range] == 1} { + if { $val == [lindex $range 0] } { + set found 1 + break + } + } elseif {[llength $range] == 2} { + set low [lindex $range 0] + set high [lindex $range 1] + + if { ![string is integer $low] \ + && [string compare "-" $low] != 0} { + return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not \u00b4-\u00b4: $range" + } + if { ![string is integer $high] \ + && [string compare "+" $high] != 0} { + return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not \u00b4+\u00b4: $range" + } + if {[string compare "-" $low] == 0} { + if { [string compare "+" $high] == 0 \ + || $val <= $high } { + set found 1 + break + } + } + if { $val >= $low } { + if {[string compare "+" $high] == 0 \ + || $val <= $high } { + set found 1 + break + } + } + } else { + return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range" + } + } + if { $found == 0 } { + return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)" + } + } + } + } + } +} diff --git a/src/project_layouts/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 new file mode 100644 index 00000000..1ede846b --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm @@ -0,0 +1,568 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) Julian Noble 2024 +# +# @@ Meta Begin +# Application argparsingtest 0.1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_argparsingtest 0 0.1.0] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require argparsingtest] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of argparsingtest +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by argparsingtest +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +package require struct::set +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval argparsingtest::class { + #*** !doctools + #[subsection {Namespace argparsingtest::class}] + #[para] class definitions + if {[info commands [namespace current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval argparsingtest { + namespace export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + + #*** !doctools + #[subsection {Namespace argparsingtest}] + #[para] Core API functions for argparsingtest + #[list_begin definitions] + + proc test1_ni {args} { + set defaults [dict create\ + -return string\ + -frametype \uFFEF\ + -show_edge \uFFEF\ + -show_seps \uFFEF\ + -x ""\ + -y b\ + -z c\ + -1 1\ + -2 2\ + -3 3\ + ] + foreach {k v} $args { + if {$k ni [dict keys $defaults]} { + error "unrecognised option '$k'. Known options [dict keys $defaults]" + } + } + set opts [dict merge $defaults $args] + } + proc test1_switchmerge {args} { + set defaults [dict create\ + -return string\ + -frametype \uFFEF\ + -show_edge \uFFEF\ + -show_seps \uFFEF\ + -x ""\ + -y b\ + -z c\ + -1 1\ + -2 2\ + -3 3\ + ] + foreach {k v} $args { + switch -- $k { + -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 {} + default { + error "unrecognised option '$k'. Known options [dict keys $defaults]" + } + } + } + set opts [dict merge $defaults $args] + } + #if we need to loop to test arg validity anyway - then dict set as we go is slightly faster than a dict merge at the end + proc test1_switch {args} { + set opts [dict create\ + -return string\ + -frametype \uFFEF\ + -show_edge \uFFEF\ + -show_seps \uFFEF\ + -x ""\ + -y b\ + -z c\ + -1 1\ + -2 2\ + -3 3\ + ] + foreach {k v} $args { + switch -- $k { + -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { + dict set opts $k $v + } + default { + error "unrecognised option '$k'. Known options [dict keys $opts]" + } + } + } + return $opts + } + variable switchopts + set switchopts [dict create\ + -return string\ + -frametype \uFFEF\ + -show_edge \uFFEF\ + -show_seps \uFFEF\ + -x ""\ + -y b\ + -z c\ + -1 1\ + -2 2\ + -3 3\ + ] + #slightly slower than just creating the dict within the proc + proc test1_switch_nsvar {args} { + variable switchopts + set opts $switchopts + foreach {k v} $args { + switch -- $k { + -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { + dict set opts $k $v + } + default { + error "unrecognised option '$k'. Known options [dict keys $opts]" + } + } + } + return $opts + } + proc test1_switch2 {args} { + set opts [dict create\ + -return string\ + -frametype \uFFEF\ + -show_edge \uFFEF\ + -show_seps \uFFEF\ + -x ""\ + -y b\ + -z c\ + -1 1\ + -2 2\ + -3 3\ + ] + set switches [lmap v [dict keys $opts] {list $v -}] + set switches [concat {*}$switches] + set switches [lrange $switches 0 end-1] + foreach {k v} $args { + switch -- $k\ + {*}$switches { + dict set opts $k $v + }\ + default { + error "unrecognised option '$k'. Known options [dict keys $opts]" + } + } + return $opts + } + proc test1_prefix {args} { + set opts [dict create\ + -return string\ + -frametype \uFFEF\ + -show_edge \uFFEF\ + -show_seps \uFFEF\ + -x ""\ + -y b\ + -z c\ + -1 1\ + -2 2\ + -3 3\ + ] + foreach {k v} $args { + dict set opts [tcl::prefix::match -message "test1_prefix option $k" {-return -frametype -show_edge -show_seps -x -y -z -1 -2 -3} $k] $v + } + return $opts + } + proc test1_prefix2 {args} { + set opts [dict create\ + -return string\ + -frametype \uFFEF\ + -show_edge \uFFEF\ + -show_seps \uFFEF\ + -x ""\ + -y b\ + -z c\ + -1 1\ + -2 2\ + -3 3\ + ] + if {[llength $args]} { + set knownflags [dict keys $opts] + } + foreach {k v} $args { + dict set opts [tcl::prefix::match -message "test1_prefix2 option $k" $knownflags $k] $v + } + return $opts + } + + #punk::args is slower than argp - but comparable, and argp doesn't support solo flags + proc test1_punkargs {args} { + set argd [punk::args::parse $args withdef { + @id -id ::argparsingtest::test1_punkargs + @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -join -type none -multiple 1 + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + @values + }] + return [tcl::dict::get $argd opts] + } + + punk::args::define { + @id -id ::test1_punkargs_by_id + @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -join -type none -multiple 1 + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + @values + } + proc test1_punkargs_by_id {args} { + set argd [punk::args::get_by_id ::test1_punkargs_by_id $args] + return [tcl::dict::get $argd opts] + } + + punk::args::define { + @id -id ::argparsingtest::test1_punkargs2 + @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -join -type none -multiple 1 + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + @values + } + proc test1_punkargs2 {args} { + set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] + return [tcl::dict::get $argd opts] + } + + + proc test1_punkargs_validate_ansistripped {args} { + set argd [punk::args::get_dict { + @id -id ::argparsingtest::test1_punkargs_validate_ansistripped + @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @opts -anyopts 0 + -return -default string -type string -choices {string object} -help "return type" + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -join -type none -multiple 1 + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean -validate_ansistripped true + -2 -default 2 -type integer -validate_ansistripped true + -3 -default 3 -type integer -validate_ansistripped true + @values + } $args] + return [tcl::dict::get $argd opts] + } + + package require opt + variable optlist + tcl::OptProc test1_opt { + {-return string "return type"} + {-frametype \uFFEF "type of frame"} + {-show_edge \uFFEF "show table outer borders"} + {-show_seps \uFFEF "show separators"} + {-join "solo option"} + {-x "" "x val"} + {-y b "y val"} + {-z c "z val"} + {-1 1 "1val"} + {-2 -int 2 "2val"} + {-3 -int 3 "3val"} + } { + set opts [dict create] + foreach v [info locals] { + dict set opts $v [set $v] + } + return $opts + } + + package require cmdline + #cmdline::getoptions is much faster than typedGetoptions + proc test1_cmdline_untyped {args} { + set cmdlineopts_untyped { + {return.arg "string" "return val"} + {frametype.arg \uFFEF "frame type"} + {show_edge.arg \uFFEF "show table borders"} + {show_seps.arg \uFFEF "show table seps"} + {join "join the things"} + {x.arg "" "arg x"} + {y.arg b "arg y"} + {z.arg c "arg z"} + {1.arg 1 "arg 1"} + {2.arg 2 "arg 2"} + {3.arg 3 "arg 3"} + } + + set usage "usage etc" + return [::cmdline::getoptions args $cmdlineopts_untyped $usage] + } + proc test1_cmdline_typed {args} { + set cmdlineopts_typed { + {return.arg "string" "return val"} + {frametype.arg \uFFEF "frame type"} + {show_edge.arg \uFFEF "show table borders"} + {show_seps.arg \uFFEF "show table seps"} + {join "join the things"} + {x.arg "" "arg x"} + {y.arg b "arg y"} + {z.arg c "arg z"} + {1.boolean 1 "arg 1"} + {2.integer 2 "arg 2"} + {3.integer 3 "arg 3"} + } + + set usage "usage etc" + return [::cmdline::typedGetoptions args $cmdlineopts_typed $usage] + } + + catch { + package require argp + argp::registerArgs test1_argp { + { -return string "string" } + { -frametype string \uFFEF } + { -show_edge string \uFFEF } + { -show_seps string \uFFEF } + { -x string "" } + { -y string b } + { -z string c } + { -1 boolean 1 } + { -2 integer 2 } + { -3 integer 3 } + } + } + proc test1_argp {args} { + argp::parseArgs opts + return [array get opts] + } + + package require tepam + tepam::procedure {test1_tepam} { + -args { + {-return -type string -default string} + {-frametype -type string -default \uFFEF} + {-show_edge -type string -default \uFFEF} + {-show_seps -type string -default \uFFEF} + {-join -type none -multiple} + {-x -type string -default ""} + {-y -type string -default b} + {-z -type string -default c} + {-1 -type boolean -default 1} + {-2 -type integer -default 2} + {-3 -type integer -default 3} + } + } { + return [dict create return $return frametype $frametype show_edge $show_edge show_seps $show_seps x $x y $y z $z 1 $1 2 $2 3 $3 join $join] + } + + #multiline values use first line of each record to determine amount of indent to trim + proc test_multiline {args} { + set t3 [textblock::frame t3] + set argd [punk::args::get_dict [subst { + -template1 -default { + ****** + * t1 * + ****** + } + -template2 -default { ------ + ****** + * t2 * + ******} + -template3 -default {$t3} + #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately + -template3b -default { + $t3 + ----------------- + $t3 + abc\ndef + } + -template4 -default "****** + * t4 * + ******" + -template5 -default " + + + " + -flag -default 0 -type boolean + }] $args] + return $argd + } + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace argparsingtest ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval argparsingtest::lib { + namespace export {[a-z]*} ;# Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace argparsingtest::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace argparsingtest::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval argparsingtest::system { + #*** !doctools + #[subsection {Namespace argparsingtest::system}] + #[para] Internal functions that are not part of the API + + + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide argparsingtest [namespace eval argparsingtest { + variable pkg argparsingtest + variable version + set version 0.1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/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 new file mode 100644 index 00000000..7884214c --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/commandstack-0.3.tm @@ -0,0 +1,514 @@ + + +#JMN 2021 - Public Domain +#cooperative command renaming +# +# REVIEW 2024 - code was originally for specific use in packageTrace +# - code should be reviewed for more generic utility. +# - API is obscure and undocumented. +# - unclear if intention was only for builtins +# - consider use of newer 'info cmdtype' - (but need also support for safe interps) +# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. +# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename +#changes: +#2024 +# - mungecommand to support namespaced commands +# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ +#2021-09-18 +# - initial version +# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command +# - They need to be able to load and unload in any order. +# + +#strive for no other package dependencies here. + + +namespace eval commandstack { + variable all_stacks + variable debug + set debug 0 + variable known_renamers [list ::packagetrace ::packageSuppress] + if {![info exists all_stacks]} { + #don't wipe it + set all_stacks [dict create] + } +} + +namespace eval commandstack::util { + #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. + #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace + #A magic comment was chosen as the identifying method. + #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. + + #return unspecified if the command is a proc with a body but no magic comment ID + #return unknown if the command doesn't have a proc body to analyze + #otherwise return the package name identified in the magic comment + proc get_IMPLEMENTOR {command} { + #assert - command has already been resolved to a namespace ie fully qualified + if {[llength [info procs $command]]} { + #look for *IMPLEMENTOR_*! + set prefix IMPLEMENTOR_ + set suffix "!" + set body [uplevel 1 [list info body $command]] + if {[string match "*$prefix*$suffix*" $body]} { + set prefixposn [string first "$prefix" $body] + set pkgposn [expr {$prefixposn + [string length $prefix]}] + #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] + set suffixposn [string first $suffix $body $pkgposn] + return [string range $body $pkgposn $suffixposn-1] + } else { + return unspecified + } + } else { + if {[info commands tcl::info::cmdtype] ne ""} { + #tcl9 and maybe some tcl 8.7s ? + switch -- [tcl::info::cmdtype $command] { + native { + return builtin + } + default { + return undetermined + } + } + } else { + return undetermined + } + } + } +} +namespace eval commandstack::renamed_commands {} +namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place + +namespace eval commandstack { + namespace export {[a-z]*} + proc help {} { + return { + + } + } + + proc debug {{on_off {}}} { + variable debug + if {$on_off eq ""} { + return $debug + } else { + if {[string is boolean -strict $debug]} { + set debug [expr {$on_off && 1}] + return $debug + } + } + } + + proc get_stack {command} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + return [dict get $all_stacks $command] + } else { + return [list] + } + } + + #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. + #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? + #e.g if renaming builtin 'package' - this command is generally called 'a lot' + proc get_next_command {command renamer tokenid} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] + if {$posn > -1} { + set record [lindex $stack $posn] + return [dict get $record implementation] + } else { + error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" + } + } else { + return $command + } + } + proc basecall {command args} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {[llength $stack]} { + set rec1 [lindex $stack 0] + tailcall [dict get $rec1 implementation] {*}$args + } else { + tailcall $command {*}$args + } + } else { + tailcall $command {*}$args + } + } + + + #review. + # defaults to calling namespace - but can be arbitrary string + proc rename_command {args} { + #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames + # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack + # + if {[lindex $args 0] eq "-renamer"} { + set renamer [lindex $args 1] + set arglist [lrange $args 2 end] + } else { + set renamer "" + set arglist $args + } + if {[llength $arglist] != 3} { + error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" + } + lassign $arglist command procargs procbody + + set command [uplevel 1 [list namespace which $command]] + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + variable all_stacks + variable known_renamers + variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. + if {$renamer eq ""} { + set renamer [uplevel 1 [list namespace current]] + } + if {$renamer ni $known_renamers} { + lappend known_renamers $renamer + dict set renamer_command_tokens [list $renamer $command] 0 + } + + #TODO - reduce emissions to stderr - flag for debug? + + #e.g packageTrace and packageSuppress packages use this convention. + set nextinfo [uplevel 1 [list\ + apply {{command renamer procbody} { + #todo - munge dash so we can make names in renamed_commands separable + # {- _dash_} ? + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] + set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. + set do_rename 0 + if {[llength [info procs $command]] || [llength [info commands $next_target]]} { + #$command is not the standard builtin - something has replaced it, could be ourself. + set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] + set munged_next_implementor [string map {:: _ns_} $next_implementor] + #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. + if {[dict exists $::commandstack::all_stacks $command]} { + set comstacks [dict get $::commandstack::all_stacks $command] + } else { + set comstacks [list] + } + set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') + if {[llength $this_renamer_previous_entries]} { + if {$next_implementor eq $renamer} { + #previous renamer was us. Rather than assume our job is done.. compare the implementations + #don't rename if immediate predecessor is same code. + #set topstack [lindex $comstacks end] + #set next_impl [dict get $topstack implementation] + set current_body [info body $command] + lassign [commandstack::lib::split_body $current_body] _ current_code + set current_code [string trim $current_code] + set new_code [string trim $procbody] + if {$current_code eq $new_code} { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [::commandstack::show_stack $command] + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." + puts stdout "----------" + puts stdout "$current_code" + puts stdout "----------" + puts stdout "$new_code" + puts stdout "----------" + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" + puts stderr + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } elseif {$next_implementor in $::commandstack::known_renamers} { + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {builtin}} { + #native/builtin could still have been renamed + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {unspecified undetermined}} { + #could be a standard tcl proc, or from application or package + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } else { + puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + #_originalcommand_ + #assume builtin/original + set next_implementor original + #rename $command $next_target + set do_rename 1 + } + #There are of course other ways in which $command may have been renamed - but we can't detect. + set token [list $command $renamer $tokenid] + return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] + } } $command $renamer $procbody] + ] + + + variable debug + if {$debug} { + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" + } else { + #assume this is the original + puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" + } + } + + #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) + #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) + set new_record [dict create\ + token [dict get $nextinfo token]\ + renamer $renamer\ + next_implementor [dict get $nextinfo next_implementor]\ + next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ + implementation [dict get $nextinfo next_target]\ + ] + if {![dict get $nextinfo do_rename]} { + #review + puts stderr "no rename performed" + return [dict create implementation ""] + } + catch {rename ::commandstack::temp::testproc ""} + set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { + #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) + set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. + set COMMANDSTACKNEXT [%next_getter%] + ## + }] + set final_procbody "$nextinit$procbody" + #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command + #(e.g due to invalid argument specifiers) + proc ::commandstack::temp::testproc $procargs $final_procbody + uplevel 1 [list rename $command [dict get $nextinfo next_target]] + uplevel 1 [list rename ::commandstack::temp::testproc $command] + dict lappend all_stacks $command $new_record + + + return $new_record + } + + #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer + #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost + #todo - removal of all entries pertaining to a particular renamer + #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? + + #remove by token, or by commandname if called from same context as original rename_command + #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. + #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. + #similarly a nonexistant token or renamer will not remove anything and will just return the current stack + proc remove_rename {token_or_command} { + if {[llength $token_or_command] == 3} { + #is token + lassign $token_or_command command renamer tokenid + } elseif {[llength $token_or_command] == 2} { + #command and renamer only supplied + lassign $token_or_command command renamer + set tokenid "" + } elseif {[llength $token_or_command] == 1} { + #is command name only + set command $token_or_command + set renamer [uplevel 1 [list namespace current]] + set tokenid "" + } + set command [uplevel 1 [list namespace which $command]] + variable all_stacks + variable known_renamers + if {$renamer ni $known_renamers} { + error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" + } + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {$tokenid ne ""} { + #token_or_command is a token as returned within the rename_command result dictionary + #search first dict value + set doomed_posn [lsearch -index 1 $stack $token_or_command] + } else { + #search second dict value + set matches [lsearch -all -index 3 $stack $renamer] + set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer + } + if {$doomed_posn ne "" && $doomed_posn > -1} { + set doomed_record [lindex $stack $doomed_posn] + if {[llength $stack] == ($doomed_posn + 1)} { + #last on stack - put the implemenation from the doomed_record back as the actual command + uplevel #0 [list rename $command ""] + uplevel #0 [list rename [dict get $doomed_record implementation] $command] + } elseif {[llength $stack] > ($doomed_posn + 1)} { + #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed + set rewrite_posn [expr {$doomed_posn + 1}] + set rewrite_record [lindex $stack $rewrite_posn] + + if {[dict get $rewrite_record next_implementor] ne $renamer} { + puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" + } else { + uplevel #0 [list rename [dict get $rewrite_record implementation] ""] + } + dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] + #don't update next_getter - it always refers to self + dict set rewrite_record implementation [dict get $doomed_record implementation] + lset stack $rewrite_posn $rewrite_record + dict set all_stacks $command $stack + } + set stack [lreplace $stack $doomed_posn $doomed_posn] + dict set all_stacks $command $stack + + } + return $stack + } + return [list] + } + + proc show_stack {{commandname_glob *}} { + variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } + if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { + #punk pipeline also needed for patterns + return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] + } else { + set result "" + set matchedkeys [dict keys $all_stacks $commandname_glob] + #don't try to calculate widest on empty list + if {[llength $matchedkeys]} { + set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] + set indent [string repeat " " [expr {$widest + 3}]] + set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide + set padkey [string repeat " " 20] + foreach k $matchedkeys { + append result "$k = " + set i 0 + foreach stackmember [dict get $all_stacks $k] { + if {$i > 0} { + append result "\n$indent" + } + append result [string range "$i " 0 4] " = " + set j 0 + dict for {k v} $stackmember { + if {$j > 0} { + append result "\n$indent2" + } + set displaykey [string range "$k$padkey" 0 20] + append result "$displaykey = $v" + incr j + } + incr i + } + append result \n + } + } + return $result + } + } + + #review + #document when this is to be called. Wiping stacks without undoing renames seems odd. + proc Delete_stack {command} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + dict unset all_stacks $command + return 1 + } else { + return 1 + } + } + + #can be used to temporarily put a stack aside - should manually rename back when done. + #review - document how/when to use. example? intention? + proc Rename_stack {oldname newname} { + variable all_stacks + if {[dict exists $all_stacks $oldname]} { + if {[dict exists $all_stacks $newname]} { + error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" + } else { + #set stackval [dict get $all_stacks $oldname] + #dict unset all_stacks $oldname + #dict set all_stacks $newname $stackval + dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] + } + } + } +} + + + + + + + + +namespace eval commandstack::lib { + proc splitx {str {regexp {[\t \r\n]+}}} { + #snarfed from tcllib textutil::splitx to avoid the dependency + # Bugfix 476988 + if {[string length $str] == 0} { + return {} + } + if {[string length $regexp] == 0} { + return [::split $str ""] + } + if {[regexp $regexp {}]} { + return -code error "splitting on regexp \"$regexp\" would cause infinite loop" + } + + set list {} + set start 0 + while {[regexp -start $start -indices -- $regexp $str match submatch]} { + foreach {subStart subEnd} $submatch break + foreach {matchStart matchEnd} $match break + incr matchStart -1 + incr matchEnd + lappend list [string range $str $start $matchStart] + if {$subStart >= $start} { + lappend list [string range $str $subStart $subEnd] + } + set start $matchEnd + } + lappend list [string range $str $start end] + return $list + } + proc split_body {procbody} { + set marker "##" + set header "" + set code "" + set found_marker 0 + foreach ln [split $procbody \n] { + if {!$found_marker} { + if {[string trim $ln] eq $marker} { + set found_marker 1 + } else { + append header $ln \n + } + } else { + append code $ln \n + } + } + if {$found_marker} { + return [list $header $code] + } else { + return [list "" $procbody] + } + } +} + +package provide commandstack [namespace eval commandstack { + set version 0.3 +}] + + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/debug-1.0.6.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/debug-1.0.6.tm new file mode 100644 index 00000000..c2ee57be --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/debug-1.0.6.tm @@ -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/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm similarity index 95% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm rename to src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm index fe16b71a..970e47da 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application fauxlink 0.1.0 +# Application fauxlink 0.1.1 # Meta platform tcl # Meta license MIT # @@ Meta End @@ -17,10 +17,10 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin fauxlink_module_fauxlink 0 0.1.0] +#[manpage_begin fauxlink_module_fauxlink 0 0.1.1] #[copyright "2024"] #[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] -#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] +#[moddesc {.fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] #[require fauxlink] #[keywords symlink faux fake shortcut toml] #[description] @@ -29,24 +29,25 @@ #[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as #[para] archiving and packaging systems. #[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. -#[para] format of name #.fxlnk +#[para] format of name #.fauxlink #[para] where can be empty - then the effective nominal name is the tail of the +#[para] The file extension must be .fauxlink or .fxlnk #[para] The + symbol substitutes for forward-slashes. #[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) #[para] We deliberately treat higher % sequences literally. #[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls. #[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 #[para] e.g a link to a file file#A.txt in parent dir could be: -#[para] file%23A.txt#..+file%23A.txt.fxlnk -#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk +#[para] file%23A.txt#..+file%23A.txt.fauxlink +#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fauxlink #[para] The can be unrelated to the actual target -#[para] e.g datafile.dat#..+file%23A.txt.fxlnk +#[para] e.g datafile.dat#..+file%23A.txt.fauxlink #[para] This system has no filesystem support - and must be completely application driven. #[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. #[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined #[para] Extensions to behaviour should be added in the file as text data in Toml format, #[para] with custom data being under a single application-chosen table name -#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system. +#[para] The toplevel Toml table [lb]fauxlink[rb] is reserved for core extensions to this system. #[para] Aside from the 2 used for delimiting (+ #) #[para] certain characters which might normally be allowed in filesystems are required to be encoded #[para] e.g space and tab are required to be %20 %09 @@ -63,9 +64,9 @@ #https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded # ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. #Using fauxlink - a link would be: -# "my-program-files#++server+c+Program%20Files.fxlnk" +# "my-program-files#++server+c+Program%20Files.fauxlink" #If we needed the old-style literal %20 it would become -# "my-program-files#++server+c+Program%2520Files.fxlnk" +# "my-program-files#++server+c+Program%2520Files.fauxlink" # # The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) # e.g @@ -296,12 +297,12 @@ namespace eval fauxlink { set is_fauxlink 0 #we'll process anyway - but return the result wrapped #This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent - #(e.g blindly processing all files in a folder that is normally only .fxlnk files - but then something added that happens + #(e.g blindly processing all files in a folder that is normally only .fauxlink files - but then something added that happens # to have # characters in it) #It also means if someone really wants to use the fauxlink semantics on a different file type # - they can - but just have to access the results differently and take that (minor) risk. #error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" - set err_extra "\nnonstandard extension '$extension_name' for fauxlink. Check that the call to fauxlink::resolve was deliberate" + set err_extra "\nnonstandard extension '$extension_name' for fauxlink. (expected .fxlnk or .fauxlink) Check that the call to fauxlink::resolve was deliberate" } else { set is_fauxlink 1 set err_extra "" @@ -318,7 +319,7 @@ namespace eval fauxlink { #if there are 4 parts - the 3rd part is a tagset where each tag begins with @ #and each subsequent part is a comment. Empty comments are stripped from the comments list #A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @ - #e.g name.txt#path#@tag1@tag2#test###.fxlnk + #e.g name.txt#path#@tag1@tag2#test###.fauxlink #has a name, a target, 2 tags and one comment #check namespec already has required chars encoded @@ -558,7 +559,7 @@ namespace eval fauxlink::system { package provide fauxlink [namespace eval fauxlink { variable pkg fauxlink variable version - set version 0.1.0 + set version 0.1.1 }] return 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/modules/fileutil/paths-1.tm new file mode 100644 index 00000000..e387acf7 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil/paths-1.tm @@ -0,0 +1,74 @@ +# paths.tcl -- +# +# Manage lists of search paths. +# +# Copyright (c) 2009-2019 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# Each object instance manages a list of paths. + +# ### ### ### ######### ######### ######### +## Requisites + +package require Tcl 8.4 +package require snit + +# ### ### ### ######### ######### ######### +## API + +snit::type ::fileutil::paths { + + # ### ### ### ######### ######### ######### + ## Options :: None + + # ### ### ### ######### ######### ######### + ## Creation, destruction + + # Default constructor. + # Default destructor. + + # ### ### ### ######### ######### ######### + ## Methods :: Querying and manipulating the list of paths. + + method paths {} { + return $mypaths + } + + method add {path} { + set pos [lsearch $mypaths $path] + if {$pos >= 0 } return + lappend mypaths $path + return + } + + method remove {path} { + set pos [lsearch $mypaths $path] + if {$pos < 0} return + set mypaths [lreplace $mypaths $pos $pos] + return + } + + method clear {} { + set mypaths {} + return + } + + # ### ### ### ######### ######### ######### + ## Internal methods :: None + + # ### ### ### ######### ######### ######### + ## State :: List of paths. + + variable mypaths {} + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide fileutil::paths 1 +return 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/modules/fileutil/traverse-0.6.tm new file mode 100644 index 00000000..2f36d109 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil/traverse-0.6.tm @@ -0,0 +1,504 @@ +# traverse.tcl -- +# +# Directory traversal. +# +# Copyright (c) 2006-2015 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 Tcl 8.3 + +# OO core +if {[package vsatisfies [package present Tcl] 8.5]} { + # 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- +} else { + # For Tcl 8.{3,4} only snit1 of a suitable patchlevel is possible. + package require snit 1.3 +} +package require control ; # Helpers for control structures +package require fileutil ; # -> fullnormalize + +snit::type ::fileutil::traverse { + + # Incremental directory traversal. + + # API + # create %AUTO% basedirectory options... -> object + # next filevar -> boolean + # foreach filevar script + # files -> list (path ...) + + # Options + # -prefilter command-prefix + # -filter command-prefix + # -errorcmd command-prefix + + # Use cases + # + # (a) Basic incremental + # - Create and configure a traversal object. + # - Execute 'next' to retrieve one path at a time, + # until the command returns False, signaling that + # the iterator has exhausted the supply of paths. + # (The path is stored in the named variable). + # + # The execution of 'next' can be done in a loop, or via event + # processing. + + # (b) Basic loop + # - Create and configure a traversal object. + # - Run a script for each path, using 'foreach'. + # This is a convenient standard wrapper around 'next'. + # + # The loop properly handles all possible Tcl result codes. + + # (c) Non-incremental, non-looping. + # - Create and configure a traversal object. + # - Retrieve a list of all paths via 'files'. + + # The -prefilter callback is executed for directories. Its result + # determines if the traverser recurses into the directory or not. + # The default is to always recurse into all directories. The call- + # back is invoked with a single argument, the path of the + # directory. + # + # The -filter callback is executed for all paths. Its result + # determines if the current path is a valid result, and returned + # by 'next'. The default is to accept all paths as valid. The + # callback is invoked with a single argument, the path to check. + + # The -errorcmd callback is executed for all paths the traverser + # has trouble with. Like being unable to cd into them, get their + # status, etc. The default is to ignore any such problems. The + # callback is invoked with a two arguments, the path for which the + # error occured, and the error message. Errors thrown by the + # filter callbacks are handled through this callback too. Errors + # thrown by the error callback itself are not caught and ignored, + # but allowed to pass to the caller, usually of 'next'. + + # Note: Low-level functionality, version and platform dependent is + # implemented in procedures, and conditioally defined for optimal + # use of features, etc. ... + + # Note: Traversal is done in depth-first pre-order. + + # Note: The options are handled only during + # construction. Afterward they are read-only and attempts to + # modify them will cause the system to throw errors. + + # ### ### ### ######### ######### ######### + ## Implementation + + option -filter -default {} -readonly 1 + option -prefilter -default {} -readonly 1 + option -errorcmd -default {} -readonly 1 + + constructor {basedir args} { + set _base $basedir + $self configurelist $args + return + } + + method files {} { + set files {} + $self foreach f {lappend files $f} + return $files + } + + method foreach {fvar body} { + upvar 1 $fvar currentfile + + # (Re-)initialize the traversal state on every call. + $self Init + + while {[$self next currentfile]} { + 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 [::control::ErrorInfoAsCaller uplevel foreach] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return + } + 4 {} + default { + return -code $code $result + } + } + } + return + } + + method next {fvar} { + upvar 1 $fvar currentfile + + # Initialize on first call. + if {!$_init} { + $self Init + } + + # We (still) have valid paths in the result stack, return the + # next one. + + if {[llength $_results]} { + set top [lindex $_results end] + set _results [lreplace $_results end end] + set currentfile $top + return 1 + } + + # Take the next directory waiting in the processing stack and + # fill the result stack with all valid files and sub- + # directories contained in it. Extend the processing queue + # with all sub-directories not yet seen already (!circular + # symlinks) and accepted by the prefilter. We stop iterating + # when we either have no directories to process anymore, or + # the result stack contains at least one path we can return. + + while {[llength $_pending]} { + set top [lindex $_pending end] + set _pending [lreplace $_pending end end] + + # Directory accessible? Skip if not. + if {![ACCESS $top]} { + Error $top "Inacessible directory" + continue + } + + # Expand the result stack with all files in the directory, + # modulo filtering. + + foreach f [GLOBF $top] { + if {![Valid $f]} continue + lappend _results $f + } + + # Expand the result stack with all sub-directories in the + # directory, modulo filtering. Further expand the + # processing stack with the same directories, if not seen + # yet and modulo pre-filtering. + + foreach f [GLOBD $top] { + if { + [string equal [file tail $f] "."] || + [string equal [file tail $f] ".."] + } continue + + if {[Valid $f]} { + lappend _results $f + } + + Enter $top $f + if {[Cycle $f]} continue + + if {[Recurse $f]} { + lappend _pending $f + } + } + + # Stop expanding if we have paths to return. + + if {[llength $_results]} { + set top [lindex $_results end] + set _results [lreplace $_results end end] + set currentfile $top + return 1 + } + } + + # Allow re-initialization with next call. + + set _init 0 + return 0 + } + + # ### ### ### ######### ######### ######### + ## Traversal state + + # * Initialization flag. Checked in 'next', reset by next when no + # more files are available. Set in 'Init'. + # * Base directory (or file) to start the traversal from. + # * Stack of prefiltered unknown directories waiting for + # processing, i.e. expansion (TOP at end). + # * Stack of valid paths waiting to be returned as results. + # * Set of directories already visited (normalized paths), for + # detection of circular symbolic links. + + variable _init 0 ; # Initialization flag. + variable _base {} ; # Base directory. + variable _pending {} ; # Processing stack. + variable _results {} ; # Result stack. + + # sym link handling (to break cycles, while allowing the following of non-cycle links). + # Notes + # - path parent tracking is lexical. + # - path identity tracking is based on the normalized path, i.e. the path with all + # symlinks resolved. + # Maps + # - path -> parent (easier to follow the list than doing dirname's) + # - path -> normalized (cache to avoid redundant calls of fullnormalize) + # cycle <=> A parent's normalized form (NF) is identical to the current path's NF + + variable _parent -array {} + variable _norm -array {} + + # ### ### ### ######### ######### ######### + ## Internal helpers. + + proc Enter {parent path} { + #puts ___E|$path + upvar 1 _parent _parent _norm _norm + set _parent($path) $parent + set _norm($path) [fileutil::fullnormalize $path] + } + + proc Cycle {path} { + upvar 1 _parent _parent _norm _norm + set nform $_norm($path) + set paren $_parent($path) + while {$paren ne {}} { + if {$_norm($paren) eq $nform} { return yes } + set paren $_parent($paren) + } + return no + } + + method Init {} { + array unset _parent * + array unset _norm * + + # Path ok as result? + if {[Valid $_base]} { + lappend _results $_base + } + + # Expansion allowed by prefilter? + if {[file isdirectory $_base] && [Recurse $_base]} { + Enter {} $_base + lappend _pending $_base + } + + # System is set up now. + set _init 1 + return + } + + proc Valid {path} { + #puts ___V|$path + upvar 1 options options + if {![llength $options(-filter)]} {return 1} + set path [file normalize $path] + set code [catch {uplevel \#0 [linsert $options(-filter) end $path]} valid] + if {!$code} {return $valid} + Error $path $valid + return 0 + } + + proc Recurse {path} { + #puts ___X|$path + upvar 1 options options _norm _norm + if {![llength $options(-prefilter)]} {return 1} + set path [file normalize $path] + set code [catch {uplevel \#0 [linsert $options(-prefilter) end $path]} valid] + if {!$code} {return $valid} + Error $path $valid + return 0 + } + + proc Error {path msg} { + upvar 1 options options + if {![llength $options(-errorcmd)]} return + set path [file normalize $path] + uplevel \#0 [linsert $options(-errorcmd) end $path $msg] + return + } + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## + +# The next three helper commands for the traverser depend strongly on +# the version of Tcl, and partially on the platform. + +# 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::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::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 + } + +} 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} { + 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 + } + + 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 + } + + return $l + } + } + + 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 + } +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide fileutil::traverse 0.6 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/flagfilter-0.3.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/flagfilter-0.3.tm new file mode 100644 index 00000000..1d37e215 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/flagfilter-0.3.tm @@ -0,0 +1,2714 @@ +#package provide flagfilter [namespace eval flagfilter {list [variable version 0.2.3]$version}] +#package provide [set ::pkg flagfilter-0.2.3] [namespace eval [lindex [split $pkg -] 0] {list [variable version [lindex [split $pkg -] 1][set ::pkg {}]]$version}] +# +#package provide [lindex [set pkg {flagfilter 0.2.3}] 0] [namespace eval [lindex $pkg 0] {list [variable version [lindex $pkg 1][set pkg {}]]$version}] +package provide [lassign {flagfilter 0.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] + +#Note: this is ugly.. particularly when trying to classify flags that are not fully specified i.e raw passthrough. +# - we can't know if a flag -x --x etc is expecting a parameter or not. +#0.2.2 2023-03 JN - added %match% placeholder support. Can be added to the dispatch command to tell it what command was actually matched. e.g tell xxx.tcl script that it was xxx.tcl when we matched on *.tcl + + +namespace eval flagfilter { + package require oolib ;# make 'oolib::collection new' available + + proc do_errorx {msg {code 1}} { + if {$::tcl_interactive} { + error $msg + } else { + puts stderr "|>err $msg" + exit $code + } + } + + proc do_error {msg {then error}} { + set levels [list debug info notice warn error critical alert emergency] + #note we exit or error out even if debug selected - as every do_error call is meant to interrupt code processing at the site of call + #this is not just a 'logging' call even though it has syslog-like level descriptors + lassign $then type code + if {$code eq ""} { + set code 1 + } + set type [string tolower $type] + if {$type in [concat $levels exit]} { + puts -nonewline stderr "|$type> $msg\n" + } else { + puts -nonewline stderr "|flagfilter> unable to interpret 2nd argument to do_error: '$then' should be one of '$levels' or 'exit '\n" + } + flush stderr + if {$::tcl_interactive} { + #may not always be desirable - but assumed to be more useful not to exit despite request, to aid in debugging + if {[string tolower $type] eq "exit"} { + puts -nonewline stderr " (exit suppressed due to tcl_interactive - raising error instead)\n" + if {![string is digit -strict $code]} { + puts -nonewline stderr "|flagfilter> unable to interpret 2nd argument to do_error: '$then' should be: 'exit '\n" + } + } + flush stderr + return -code error $msg + } else { + if {$type ne "exit"} { + return -code error $msg + } else { + if {[string is digit -strict $code]} { + exit $code + } else { + puts -nonewline stderr "|flagfilter> unable to interpret 2nd argument to do_error: '$then' should be 'error' or 'exit '\n" + flush stderr + return -code error $msg + } + } + } + } + proc scriptdir {} { + set possibly_linked_script [file dirname [file normalize [file join [info script] ...]]] + if {[file isdirectory $possibly_linked_script]} { + return $possibly_linked_script + } else { + return [file dirname $possibly_linked_script] + } + } + +} + +package require overtype + + +namespace eval flagfilter { + namespace export get_one_flag_value + #review. Tcl can handle args like: {-a -val1 -b -val2} as long as they pair up. + #this will ignore flag-like values if they follow a -flag + # positional values that happen to start with - can still cause issues + #get_flagged_only can return an unpaired list if there are solos, or if it finds no value for the last flaglike element + # e.g from input {something -x -y -z} we will get {-x -y -z} + # + # + + #flagfilter::get_flagged_only may not always get things right when looking at a values list with command processors + #Even if all solos from commands are supplied in solodict - a flag might be solo only in the context of a particualar commandset + #The proper way to get flagged values from an arglist is to run the full parser. + #This then should be restricted to use for a specific subset of args where the supplied solodict is known to apply + proc get_flagged_only {arglist solodict} { + #solodict - solo flags with defaults + set solo_accumulator [dict create] ;#if multiple instances of solo flag found - append defaults to the value to form a list as long as the number of occurrences + #puts ">>>get_flagged_only input $arglist solodict:'$solodict'" + set result [list] + set last_was_flag 0 + set result [list] + set a_idx 0 + set end_of_options 0 + foreach a $arglist { + if {$a eq "--"} { + break + } + if {[dict exists $solodict $a]} { + set last_was_flag 0 + if {[dict exists $solo_accumulator $a]} { + set soloval [concat [dict get $solo_accumulator $a] [dict get $solodict $a]] + } else { + set soloval [dict get $solodict $a] + } + dict set solo_accumulator $a $soloval + #we need to keep order of first appearance + set idx [lsearch $result $a] + if {$idx < 0} { + lappend result $a $soloval + } else { + lset result $idx+1 $soloval + } + } else { + if {!$last_was_flag} { + if {$a eq "--"} { + + } else { + if {[lindex $arglist $a_idx-1] eq "--"} { + #end of options processing - none of the remaining are considered flags/options no matter what they look like + set last_was_flag 0 + break + } else { + if {[string match -* $a]} { + set last_was_flag 1 + lappend result $a ;#flag + } else { + #last wasnt, this isn't - don't output + set last_was_flag 0 + } + } + } + } else { + #we only look for single leading - in the value if last wasn't a flag - but we give -- and soloflags special treatment. + if {$a eq "--"} { + #last was flag + set last_was_flag 0 + } else { + lappend result $a ;#value + set last_was_flag 0 + } + } + } + incr a_idx + } + if {([llength $result] % 2) != 0} { + set last [lindex $result end] + if {[string match -* $last] && ($last ni [dict keys $solodict])} { + lappend result 1 + } + } + #puts ">>>get_flagged_only returning $result" + return $result + } + + + ## get_one_paired_flag_value + #best called with 'catch' unless flag known to be in arglist + #raises an error if no position available after the flag to retrieve value + #raises an error if flag not like -something + #raises an error if flag not found in list + proc get_one_paired_flag_value {arglist flag} { + if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $flag]} { + #regexp excludes plain - and -- + #if {![string match -* $flag]} {} + error "get_one_flag_value flag $flag does not look like a flag. Should be something like -$flag or --$flag" + } + set cindex [lsearch $arglist $flag] + if {$cindex >= 0} { + set valueindex [expr {$cindex + 1}] + if {$valueindex < [llength $arglist]} { + #puts stderr "++++++++++++++++++ get_one_flag_value flag '$flag' returning [lindex $arglist $valueindex]" + return [lindex $arglist $valueindex] + } else { + error "flagfilter::get_one_paired_flag_value no value corresponding to flag $flag (found flag, but reached end of list)" + } + } else { + error "flagfilter::get_one_paired_flag_value $flag not found in arglist: '$arglist'" + } + } +} + +namespace eval flagfilter::obj { + +} + + +namespace eval flagfilter { + variable run_counter 0 ;#Used by get_new_runid to form an id to represent run of main check_flags function. + #used as a basis for some object-instance names etc + proc get_new_runid {} { + variable run_counter + if {[catch {package require Thread}]} { + set tid 0 + } else { + set tid [thread::id] + } + return "ff-[pid]-${tid}-[incr run_counter]" + } + + namespace export check_flags + proc do_debug {lvl debugconfig msg} { + if {$lvl <= [dict get $debugconfig -debugargs]} { + foreach ln [split $msg \n] { + puts -nonewline stderr "|[dict get $debugconfig -source]> $ln\n" + flush stderr + } + } + } + + #---------------------------------------------------------------------- + # DO NOT RELY ON tcl::unsupported - it's named that for a reason and is not meant to be parsed + #wiki.tcl-lang.org/page/dict+tips+and+tricks + proc isdict {v} { + if {[string match "value is a list *" [::tcl::unsupported::representation $v]]} { + return [expr {!([llength $v] % 2)}] + } else { + return [string match "value is a dict *" [::tcl::unsupported::representation $v]] + } + } + + proc dict_format {dict} { + dictformat_rec $dict "" " " + } + proc dictformat_rec {dict indent indentstring} { + # unpack this dimension + set is_empty 1 + dict for {key value} $dict { + set is_empty 0 + if {[isdict $value]} { + append result "$indent[list $key]\n$indent\{\n" + append result "[dictformat_rec $value "$indentstring$indent" $indentstring]\n" + append result "$indent\}\n" + } else { + append result "$indent[list $key] [list $value]\n" + } + } + if {$is_empty} { + #experimental.. + append result "$indent\n" + #append result "" + } + return $result + } + #-------------------------------------------------------------------------- + + #solo 'category' includes longopts with value + #solo flags include the general list of -soloflags, and those specific to the current -commandprocessors spec (mashopts and singleopts) + proc is_this_flag_solo {f solos objp} { + if {![string match -* $f]} { + #not even flaglike + return 0 + } + + + if {$f in $solos} { + #review! - global -soloflags shouldn't override the requirements of a commandprocessor! + #but.. each commandprocessor needs to understand global solos occuring before our match so that we classify correctly.. + #todo - this may need to reference v_map and current position in scanlist to do properly + return 1 + } + if {$f eq "-"} { + #unless the caller declared it as a solo - treat this as a non flag element. (likely use is as a command match) + return 0 + } + if {$f eq "--"} { + #this is it's own type endofoptions + return 0 + } + + set p_opts [$objp get_combined_opts] + + set mashopts [dict get $p_opts mashopts] + set singleopts [dict get $p_opts singleopts] + set pairopts [dict get $p_opts pairopts] + set longopts [dict get $p_opts longopts] + + if {$f in $singleopts} { + return 1 + } + + #"any" keywords used by processors to consume anything - where we're not too worried about classifying a flagvalue vs an operand + #examine these last so that an explicit configuration of flags as pairopts,mashopts etc can still be classified correctly + if {"any" in $singleopts} { + return 1 + } + if {[string first "=" $f] >=1} { + if {"any" in $longopts} { + return 1 + } + #todo foreach longopt - split on = and search + } + + #Flag could still be part of a solo if it is in mashopts *and* has a value following it as part of the mash - but if it's a pairopt, but not mashable - we can rule it out now + if {($f in $pairopts) && ($f ni $mashopts)} { + return 0 + } + #todo - suport mashes where one of the mashed flags takes an arg - review: only valid if it's last in the mash? + #(presumably so - unless we there was some other value delimiter such as isnumeric or capitalised flags vs lowercase values - but that seems a step too far - would require some sort of mashspec/mash-strategy config) + #last part of mash may actually be the value too. which complicates things + #linux ls seems to do this for example: + # ls -w 0 + # ls -lw 0 + # ls -lw0 + # also man.. e.g + # man -Tdvi + # man -Hlynx + # man -H + # - note this last one. '-H lynx' doesn't work - so it's a mashable opt that can take a value, but is not in pairopts! (-H with no value uses env value for browser) + # see also comments in is_this_flag_mash + # + + set flagletters [split [string range $f 1 end] ""] + set posn 1 + set is_solo 1 ;#default assumption to disprove + #trailing letters may legitimately not be in mashopts if they are part of a mashed value + #we can return 0 if we hit a non-mash flag first.. but at each mashflag we need to test if we can classify as definitely solo or not, or else keep processing + foreach l $flagletters { + if {"-$l" ni $mashopts} { + #presumably an ordinary flag not-known to us + return 0 + } else { + if {"-$l" in $pairopts} { + if {$posn == [llength $flagletters]} { + #in pairopts and mash - but no value for it in the mash - thefore not a solo + return 0 + } else { + #entire tail is the value - this letter is effectively solo + return 1 + } + } elseif {"-$l" in $singleopts} { + #not allowed to take a value - keep processing letters + } else { + #can take a value! but not if at very end of mash. Either way This is a solo + return 1 + } + } + } + return $is_solo + } + #todo? support global (non-processor specific) mash list? -mashflags ? + proc is_this_flag_mash {f objp} { + if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $f]} { + #not even flaglike + return 0 + } + set optinfo [$objp get_combined_opts];#also applies to tail_processor - *usually* empty values for mashopts etc + + #we look at singleopts because even if the flag is in mashopts - when it is alone we don't classify it as a mash + set singleopts pdict get $optinfo singleopts] + if {$f in $singleopts} { + return 0 + } + + set pairopts [dict get $optinfo pairopts] + if {$f in [dict keys $pairopts]} { + #here, the entire arg (f) we are testing is in pairopts - it could still however appear as part of a mash, with or without a trailing value, and with or without other flags before it in the mash (but if neither prefixed,nor tailed then obviously not a mash) + return 0 + } + set mashopts [dict get $optinfo mashopts] + set flagletters [split [string range $f 1 end] ""] + set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash.. unless trailing one also takes a value + # .. in which case value could be at the tail of the mash.. or be the next arg in the list + # We will take absense from singleopts and pairopts to indicate the mashflag *optionally* takes a value + # (ie such a mashopt is a solo that can take a value only as a mashtail) + # presence in pairopts indicates a mashflag must have a value + # presense in singleopts indicates mashflag takes no value ever. + # mashopt cannot be in both singleopts and pairopts. (NAND) + foreach l $flagletters { + if {-$l in $pairopts} { + if {"-$l" in $mashopts} { + #need to consider any remainder in the mash as this value .. if no remainder - then this is a mash, but not 'solo' because this flag needs to consume the following arg. + # We are only concerned with mashness here so just stop processing mash elements when we hit the first one that is a pairopt + break + } else { + #we require the pairopt to explicitly be listed in mashopts as well as pairopts if it is to be allowed to be part of a mash + set is_mash 0 + } + } elseif {"-$l" in $singleopts} { + #singleopt & mashopt - cannot take a value, mashed or otherwise + if {"-$l" ni $mashopts} { + set is_mash 0 + } + } else { + if {"-$l" ni $mashopts} { + set is_mash 0 + } else { + #present only in mashopts - can take a value, but only immediately following in the mash + break + } + } + } + return $is_mash + } + proc is_this_flag_for_me {f objp cf_args} { + set processorname [$objp name] + set optinfo [$objp get_combined_opts] ;#also applies to tail_processor - *usually* empty values for mashopts etc + + if {$processorname in [list "tail_processor"]} { + return 1 + } + if {$processorname in [list "global"]} { + #todo - mashflags for global? + set defaults [dict get $cf_args -defaults] + set extras [dict get $cf_args -extras] + set soloflags [dict get $cf_args -soloflags] + if {$f in [concat $extras $soloflags [dict keys $defaults]]} { + return 1 + } + } + + set singleopts [dict get $optinfo singleopts] + if {"any" in [string tolower $singleopts]} { + #review semantics of 'all' here. does it mean any -xxx.. will match, or only if also in global -soloflags? + return 1 + } + set pairopts [dict get $optinfo pairopts] + set allopts [concat $singleopts [dict keys $pairopts]] + if {$f in $allopts} { + return 1 + } + + #process mashopts last + set mashopts [dict get $optinfo mashopts] + if {"any" in [string tolower $mashopts]} { + #if 'all' in mashopts - it can eat anything - review - is this even useful? + return 1 + } else { + set flagletters [split [string range $f 1 end] ""] + set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash + foreach l $flagletters { + if {"-$l" ni $mashopts} { + set is_mash 0 + } + } + return $is_mash + } + + return 0 + } + + + + proc add_dispatch_raw {recordvar parentname v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname raw] + lappend dispatchinfo $v + dict set drecord $parentname raw $dispatchinfo + } + } + proc add_dispatch_argument {recordvar parentname k v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname arguments] + lappend dispatchinfo $k $v ;#e.g -opt 1 + dict set drecord $parentname arguments $dispatchinfo + } + } + proc lsearch-all-stride-2 {l search} { + set posns [lmap i [lsearch -all $l $search] {expr {($i % 2) == 0 ? $i : [list x]}}] + return [lsearch -all -inline -not $posns x] + } + proc update_dispatch_argument {recordvar parentname k v} { + upvar $recordvar drecord + if {[dict exists $drecord $parentname]} { + set dispatchinfo [dict get $drecord $parentname arguments] + #can't assume there aren't repeat values e.g -v -v + #dict set dispatchinfo $k $v + if {[package vcompare [info tclversion] 8.7a5] >= 0} { + set posns [lsearch -all -stride 2 $dispatchinfo $k] + } else { + set posns [lsearch-all-stride-2 $dispatchinfo $k] + } + set lastitem [lindex $posns end] + if {[string length $lastitem]} { + set val_idx [expr {$lastitem + 1}] + set dispatchinfo [lreplace $dispatchinfo[set dispatchinfo {}] $val_idx $val_idx $v] ;# inlineK + dict set drecord $parentname arguments $dispatchinfo + } else { + error "Unable to update dispatch argument $k with value $v in dispatch record for $parentname" + } + #dict set drecord $parentname $dispatchinfo + } + } + + #Note the difference between this and is_command_match. + #Lack of a 'match' element does not cause a commandspec to skip allocating an operand it encounters + #Note that this isn't a general test to be applied to the entire argument list. + # - an arg may get matched by an earlier processor making it unavailable to be allocated by another processor + # so this test only applies during the ordered examination of args + proc can_this_commandspec_allocate_this_arg {flag cspec cf_args} { + set cmdinfo [lindex $cspec 1] + if {$cmdinfo eq "tail_processor"} { + return 1 + } + if {$cmdinfo eq "global"} { + set defaults [dict get $cf_args -defaults] + set soloflags [dict get $cf_args -soloflags] + set extras [dict get $cf_args -extras] + if {$flag in [concat $soloflags $extras [dict keys $defaults]]} { + return 1 + } + } + if {![dict exists $cmdinfo match]} { + return 1 + } + set matchspeclist [dict get $cmdinfo match] + foreach matchspec $matchspeclist { + if {[regexp -- $matchspec $flag]} { + return 1 + } + } + #only block it if there was a match pattern specified but it didn't match + return 0 + } + #Note - returns false for a cspec that has no match specified. + #A command/subcommand with no match specification is allowed to allocate any value - so be careful with this + # - it should not be used to *stop* an arg being allocated if the processor has no 'match' specified, or if it is another type of processor like 'tail_handler'. + proc is_command_match {flag cspec} { + set pinfo [lindex $cspec 1] + if {[dict exists $pinfo match]} { + set matchspeclist [dict get $pinfo match] + foreach matchspec $matchspeclist { + if {[regexp -- $matchspec $flag]} { + return 1 + } + } + return 0 + } else { + return 0 + } + } + proc is_command_match_any {f commandprocessors} { + foreach comspec $commandprocessors { + lassign $comspec cmdname cmdinfo + if {[dict exists $cmdinfo match]} { + set matchlist [dict get $cmdinfo match] + foreach matchspec $matchlist { + if {[regexp -- $matchspec $f]} { + #actually a command + return true + } + } + } + } + return false + } + + #determine if f is potentially a flag that takes a parameter from the next argument. + #e.g --x=y (longopt) does not consume following arg but --something *might* + proc is_candidate_toplevel_param_flag {f solos commandprocessors} { + if {[is_command_match_any $f $commandprocessors]} { + return false + } + if {$f in $solos} { + return 0 + } + if {$f in {- --}} { + return 0 + } + #longopts (--x=blah) and alternative --x blah + #possibly also -x=blah + if {[string match -* $f]} { + if {[string first "=" $f]>1} { + return 0 + } + } + return [expr {[string match -* $f]}] + } + + + + + + + + + + + + + + + + + + + #review - should we be using control::assert here? + #It depends if this is intended to raise error at runtime - would using control::assert and disabling assertions cause problems? + #todo - show caller info + proc assert_equal {a b} { + if {![expr {$a eq $b}]} { + error "assert_equal $a $b" + } + } + + + + + + #{1 unallocated 2 unallocated 3 unallocated 4 unallocated 5 unallocated 6 unallocated} ;#initial v_map + #1 2 3 4 5 6 ;#original list posns example + # 2 6 ;#map_remaining example (scanlist) + #1 3 4 5 ;#map_allocated example + #{1 {cmd1 operand} 2 unallocated 3 {cmd2 operand} 4 {cmd2 flag} 5 {cmd2 flagvalue} 6 unallocated} ;#v_map updated example + oo::class create class_vmap { + variable o_map + variable o_remaining + variable o_allocated + variable o_values + variable o_codemap + variable o_flagcategory + constructor {values} { + set o_codemap [dict create \ + operand op \ + flagvalue fv \ + soloflag so \ + flag fl \ + unallocated un \ + endofoptions eo \ + ] + set o_flagcategory [list "flag" "flagvalue" "soloflag"] + set o_values $values + #set o_remaining [lsearch -all $values *] ;#create a list of indices e.g 0 1 2 3 4 5 6 + #lsearch -all * is fast for very small lists - but lseq wins from size around 30+ + if {[llength $values]} { + if {[llength $values] < 30} { + #common case is short lists - but we don't want to penalize large lists + set o_remaining [lsearch -all $values *] + } else { + #punk::lib::range wraps lseq if available + set o_remaining [punk::lib::range 0 [llength $values]-1] + } + } else { + set o_remaining [list] + } + set o_allocated [list] + set o_map [list] + foreach posn $o_remaining { + lappend o_map $posn unallocated + } + } + method load {values rem alloc map} { + set o_values $values + set o_remaining $rem + set o_allocated $alloc + set o_map $map + } + method copy_to {obj} { + $obj load $o_values $o_remaining $o_allocated $o_map + } + method update_map_from {obj} { + #very basic sanity check first + if {[llength $o_values] ne [llength [$obj get_values]]} { + error "[self class].update_map_from cannot update. length of values mismatch" + } + + set newmap [$obj get_map] + } + + method get_codemap {} { + return $o_codemap + } + method get_values {} { + return $o_values + } + method get_remaining {} { + return $o_remaining + } + method get_allocated {} { + return $o_allocated + } + method get_map {} { + return $o_map + } + method argnum_from_remaining_posn {scanlist_posn} { + set vidx [lindex $o_remaining $scanlist_posn] + if {![string is digit -strict $vidx]} { + return -code error "[self class].argnum_from_remaining_posn cannot determine argnum from scanlist position:$scanlist_posn using unallocated list:'$o_remaining'" + } + return $vidx + } + + method allocate {objp argnum type value} { + set processorname [$objp name] + if {$processorname eq "tail_processor"} { + set owner "unallocated" + } else { + set owner [$objp parentname] + } + if {$argnum > [llength $o_values]-1} { + return -code error "[self class].allocate cannot allocate argnum:$argnum. Only [llength $o_values] items in value list" + } + if {$argnum in $o_allocated} { + return -code error "[self class].allocate already allocated '$processorname' argnum:'$argnum' type:'$type' val:'$value' remaining:$o_remaining allocated:$o_allocated map:$o_map" + } + lappend o_allocated $argnum + set o_allocated [lsort -dictionary $o_allocated] + dict set o_map $argnum [list $owner $type $value] + set scanlist_posn [lsearch $o_remaining $argnum] + set o_remaining [lreplace $o_remaining[set o_remaining {}] $scanlist_posn $scanlist_posn] ;#inlineK + + + + } + + method get_list_unflagged_by_class {classmatch} { + set resultlist [list] + dict for {k vinfo} $o_map { + lassign $vinfo class type val + if {[string match $classmatch $class]} { + switch -- $type { + flag - flagvalue - soloflag {} + default { + lappend resultlist $val + } + } + } + } + return $resultlist + } + + method get_list_flagged_by_class {classmatch} { + set list_flagged [list] + dict for {k vinfo} $o_map { + lassign $vinfo class type val + if {[string match $classmatch $class]} { + switch -- $type { + flag - flagvalue - soloflag { + lappend list_flagged $val + } + } + } + } + return $list_flagged + } + + method get_merged_flagged_by_class {classmatch} { + variable flagcategory + set all_flagged [list] + set seenflag [dict create] ;#key = -flagname val=earliest vindex + dict for {k vinfo} $o_map { + lassign $vinfo class type val + if {[string match $classmatch $class]} { + set a [llength $all_flagged] ;#index into all_flagged list we are building + switch -- $type { + soloflag { + if {[dict exists $seenflag $val]} { + set seenindex [dict get $seenflag $val] + set seenindexplus [expr {$seenindex+1}] + set existingvals [lindex $all_flagged $seenindexplus] + lappend existingvals 1 ;#1 indicating presence - stored as list rather than a count. todo: consider global or per-solo options to support incrementing instead? + lset all_flagged $seenindexplus $existingvals + } else { + dict set seenflag $val $a + lappend all_flagged $val 1 + } + } + flag { + if {![dict exists $seenflag $val]} { + dict set seenflag $val $a + lappend all_flagged $val + } + #no need to do anything if already seen - flagvalue must be next, and it will work out where to go. + } + flagvalue { + set idxflagfor [expr {$k -1}] + set flagforinfo [dict get $o_map $idxflagfor] + lassign $flagforinfo ffclass fftype ffval + #jn "--" following a flag could result in us getting here accidentaly.. review + set seenindex [dict get $seenflag $ffval] + if {$seenindex == [expr {$a-1}]} { + #usual case - this is a flagvalue following the first instance of the flag + lappend all_flagged $val + } else { + #write the value back to the seenindex+1 + set seenindexplus [expr {$seenindex+1}] + set existingvals [lindex $all_flagged $seenindexplus] + lappend existingvals $val ;#we keep multiples as a list + lset all_flagged $seenindexplus $existingvals + } + } + } + } + } + return $all_flagged + } + method typedrange_class_type_from_arg {argclass argtype} { + #set o_flagcategory [list "flag" "flagvalue" "soloflag"] + if {$argclass eq "unallocated"} { + switch -- $argtype { + flag - flagvalue - soloflag { + return [list unallocated flagtype] + } + default { + if {![string length $argtype]} { + #should only happen if something wrong with the tail_processor - rather than error out, for now at least make it stand out in the . + set argtype UNKNOWN + } + return [list unallocated ${argtype}type] ;#e.g unallocated_operand, unallocated_endofoptions + } + } + } else { + return [list $argclass argtype] ;# e.g command something + } + } + + method get_ranges_from_classifications {classifications} { + #puts stderr "get_ranges_from_classifications $classifications" + #examine classifications and create a list of ranges + set ranges [list];# e.g [list {unallocated 0 4} {cmd1 5 7} {unallocated 8 8} {cmd2 9 9} {cmd3 10 10} {unallocated 11 15}] + set seen_commands [list] + dict for {posn arginfo} $classifications { + set is_new_cmd 0 + set is_sub_cmd 0 + set is_continuation 0 + set rangename [lindex $ranges end 0] + set alloc [lindex $arginfo 0] ;#e.g of form 0 {unallocated operand} 1 {lscmd operand} 2 {lscmd soloflag} 3 {lscmd.dir operand} 4 {unallocated flag} + set cmdname "" + if {$alloc ne "unallocated"} { + if {$alloc ni $seen_commands} { + if {![llength $seen_commands]} { + set cmdname $alloc + set is_new_cmd 1 + } else { + set tail [lindex $seen_commands end] + if {$tail eq "unallocated"} { + set cmdname $alloc + set is_new_cmd 1 + } else { + if {[string first . $alloc] >= 0} { + set prefixcheck [lindex [split $alloc .] 0] + if {![string equal -length [string length $prefixcheck] $prefixcheck $tail]} { + #this is not unallocated, not a subcommand of the previous seen ie new command + set cmdname $alloc + set is_new_cmd 1 + } else { + set cmdname $prefixcheck + set is_sub_cmd 1 + set is_continuation 1 + } + } else { + set cmdname $alloc + set is_new_cmd 1 + } + } + } + } else { + set cmdname $alloc + set is_continuation 1 + } + if {$is_continuation} { + lassign [lindex $ranges end] _cmd n a b + set ranges [lrange $ranges 0 end-1] + lappend ranges [list command $n $a [incr b]] + flagfilter::assert_equal $b $posn + } elseif {$is_new_cmd} { + lappend seen_commands $alloc + if {$rangename eq ""} { + lappend ranges [list command $cmdname $posn $posn] + } else { + lassign [lindex $ranges end] _cmd n a b + lappend ranges [list command $cmdname [incr b] $posn] + flagfilter::assert_equal $b $posn + } + } else { + error "coding error during dispatch" + } + } else { + if {$rangename eq ""} { + lappend ranges [list unallocated mixed 0 0] + } else { + lassign [lindex $ranges end] class n a b + if {$class eq "unallocated"} { + #continuation - extend + set ranges [lrange $ranges 0 end-1] + lappend ranges [list unallocated mixed $a [incr b]] + } else { + #change from allocated to unallocated + lappend ranges [list unallocated mixed [incr b] $posn] + flagfilter::assert_equal $b $posn + } + } + } + } + set rangesbytype [list] + foreach oldrange $ranges { + lassign $oldrange oldrangeclass oldrangetype A B ;#A,B for original range bounds, a,b for bounds of sub-ranges we are creating + set last_type "" + set newrangelist [list] + set inner_range [list 0 0] + if {$oldrangeclass ne "unallocated"} { + #pass through - user can split commands further themselves by referencing the classifications map where each arg position is listed + set last_type $oldrangeclass ;#note the deliberate slight misuse - we are using the 'class' here rather than the type as we aren't looking at types within a command range + lappend rangesbytype $oldrange + } else { + #puts stdout "???????????????????????????????????????????????A$A B$B examining old range:'$oldrange'" + for {set i $A} {$i <= $B} {incr i} { + lassign [lindex $rangesbytype end] last_class last_type a b ;#enough just to use the type without the class + set a_info [dict get $classifications $i] + lassign $a_info argclass argtype v + lassign [my typedrange_class_type_from_arg $argclass $argtype] newrangeclass newrangetype + if {$last_type eq ""} { + lappend rangesbytype [list "unallocated" $newrangetype 0 0] + } else { + if {$last_type eq $newrangetype} { + set rangesbytype [lrange $rangesbytype 0 end-1] + lappend rangesbytype [list $last_class $last_type $a $i] + } else { + lappend rangesbytype [list $newrangeclass $newrangetype $i $i] + } + } + } + } + } + + return [list -ranges $ranges -rangesbytype $rangesbytype] + } + + method grid {} { + set posns [dict keys $o_map] + set col1 [string repeat " " 15] + set col [string repeat " " 4] + set pline "[overtype::left $col1 {var indices}] " + foreach p $posns { + append pline [overtype::left $col $p] + } + set remline "[overtype::left $col1 {unallocated}] " + foreach vidx $posns { + if {$vidx ni $o_remaining} { + append remline [overtype::left $col "."] + } else { + set tp [lindex [dict get $o_map $vidx] 1] + #set tp [string map $o_codemap $tp] + if {[dict exists $o_codemap $tp]} { + set tp [dict get $o_codemap $tp] + } + append remline [overtype::left $col $tp] + } + } + set cmdlist [list] + dict for {vidx info} $o_map { + if {[lindex $info 0] ne "unallocated"} { + set c [lindex [split [lindex $info 0] .] 0] + if {$c ni $cmdlist} { + lappend cmdlist $c + } + } + } + set clinelist [list] + foreach c $cmdlist { + set cline "[overtype::left $col1 $c] " + dict for {vidx info} $o_map { + lassign $info class type v + if {($c eq $class) || [string equal -length [string length "$c."] "$c." $class]} { + #set tp [string map $o_codemap $type] + if {[dict exists $o_codemap $type]} { + set tp [dict get $o_codemap $type] + } + append cline [overtype::left $col $tp] + } else { + append cline [overtype::left $col "."] + } + } + lappend clinelist $cline + } + + + set aline "[overtype::left $col1 {allocated}] " + foreach vidx $posns { + if {$vidx ni $o_allocated} { + append aline [overtype::left $col "."] + } else { + set tp [lindex [dict get $o_map $vidx] 1] + #set tp [string map $o_codemap $tp] + if {[dict exists $o_codemap $tp]} { + set tp [dict get $o_codemap $tp] + } + append aline [overtype::left $col $tp] + } + } + + return "$pline\n$remline\n[join $clinelist \n]\n$aline\n" + } + + } + + + #!todo - check if -commandprocessors members will collide with existing -flags in values before moving them + #!todo - skip optional sub-flag value if the next arg following its parent is a flag i.e proper handling of -commandprocessors {cmd {cmd sub "default}} when only cmd supplied. + #!important to fix. At the moment it could eat a further unflagged item in values later in the list which was intended for a different -commandprocessors member! + #add support for -commandprocessors {-cmd {-cmd -othercmd "default"}} to be a safe way to specify a linked -flag move that does the same. + proc allocate_arguments {PROCESSORS solos values cf_args caller} { + set runid [lindex [split [namespace tail $PROCESSORS] _] 1] ;# objname is of form PROCESSORS_pid-threadid-counter where "PROCESSORS_" is a literal + #puts stderr ">>>>>>> solos: $solos" + dict set debugc -debugargs [dict get $cf_args -debugargs] + dict set debugc -source "allocate_arguments $caller" + + set defaults [dict get $cf_args -defaults] + + set cmdprocessor_records [$PROCESSORS get_commandspecs] + + + set sep "\uFFFE" ;#argument-subargument separator (choose something else if this causes problems.. but we want something unlikely (or preferably impossible?) to be in a commandline, ideally a single character, and which at least shows something on screen during debug) + set sepstr "\\uFFFE" ;#for human readable error msg + #\u001E was tried and doesn't output on some terminals) + + set remaining_unflagged [dict create] + + set extra_flags_from_positionals [list] ;#values moved to -values + set moved_to_flagged [dict create] + + #implied_ are values supplied from defaults when a flag or operand was not found + set implied_flagged [list] + set implied_unflagged [list] + + + set dispatch [dict create] + #sanitize and raise error if sep somehow in values + if {[string first $sep $cmdprocessor_records] >= 0} { + do_error "allocate_arguments flags error separator '$sep' ($sepstr) found in values " + } + #-------------------------------------- + set VMAP [flagfilter::class_vmap create flagfilter::VMAP_$runid $values] + #-------------------------------------- + + set unconsumed_flags_and_values [list] + set unflagged [dict create] + + ###################### + #main -commandprocessors loop which scans the valuelist + set values_index 0 ;#track where we are up to as we allocate values to unflagged elements + set source_values $values ;#start with all including -flagged + + #todo - get rid of most of these flags last_x_was etc - and just do lookups into the v_map + # as this will probably involve *lots* of small functiona calls - keep this boolean version and check for performance issues. + set a_index 0 + set is_args_flag 0 + set last_arg_was_paramflag 0 ;#a flag that expects a parameter to follow + set last_arg_was_solo 0 + set solo_flags [dict keys $solos] ;#solos is a dict of -flag (preprocessed) + set end_of_options 0 + set end_of_options_index -1 ;#as later processors can rescan - we need to make sure they only look at arguments after this point + set last_p_found [dict create by "" index "" item ""] + set sequence 0 + set argerrors [list] ;#despite being a list - we will break out at first entry and return for now. + set parsestatus "ok" + + #set LAUNCHED [oolib::collection create col_processors_launched_$runid] + #set MATCHED [oolib::collection create col_processors_matched_$runid] + #oo::objdefine col_processors_matched_$runid { + # method test {} { + # return 1 + # } + #} + + #set objp [$PROCESSORS object_from_record $p] ;#temp convenience + + foreach objp [$PROCESSORS items] { + set objparent [$objp parent] + #$LAUNCHED add $objp [$objp name] + set p [$objp get_def] ;#individual record e.g {mycmd {match run singleopts {-x}}} or {tail_processor {}} + + lassign $p parentname pinfo + set is_sub [$objp is_sub] ;#is subargument - should look to see if last related spec got a value and abort if not. + set is_p_flag [$objp is_flag] ;#sub can be a flag even if parent isn't + set processorname [$objp name] + if {[$objp is_sub]} { + if {![[$objp parent] found_match]} { + continue + } + set p_sub [dict get $pinfo sub] + } + do_debug 3 $debugc " =========================>> p $p sequence:$sequence a_index $a_index" + + if {$processorname in [list "global" "tail_processor"]} { + dict set last_p_found by $processorname + #dict set last_p_found index $a_index + #dict set last_p_found item $a + } + # -format {x {sub y default "default"}} means y is dependent on x being present and shouldn't eat if the next value isn't flaglike + # -format {-x {sub -y}} does the same for moving positionals to the flagged list. + + + #set remaining_values [lrange $source_values $a_index end] + ##################################### + # full rescans for later processors + set remaining_values $source_values ;#source_values shrinks as commands take arguments + set a_index 0 + ##################################### + + do_debug 3 $debugc "-------->________>p '$processorname' remaining vals $remaining_values" + + #!todo - use v_map as an extra determinant to stop sequence for a command-set. (don't extend beyond where args have already been snipped by another command) + if {[$objp name] eq "tail_processor"} { + set mapcopy [flagfilter::class_vmap new {}] ;#no need to supply values as we are copying data from $VMAP + $VMAP copy_to $mapcopy + $objp set_map_object $mapcopy + } else { + $objp set_map_object $VMAP + } + foreach a $remaining_values { + set argnum [[$objp get_map_object] argnum_from_remaining_posn $a_index] + if {![string is integer -strict $argnum]} { + error "arg '$a' scan_index:$a_index - calculated argnum:'$argnum' is invalid" + + } + set sub_operand 0 + do_debug 3 $debugc "$argnum >eoptions_idx:$end_of_options_index a_index:$a_index __________________________________________________________a $a" + if {$end_of_options_index > -1} { + set end_of_options [expr {$a_index >= $end_of_options_index}] + } + + #review - data with leading - may be unintentionally interpreted as a flag + if {[string trim $a] eq "--"} { + #generally means end of options processing.. + #review - pass -- through?? + set last_arg_was_paramflag 0 ;#we don't treat first arg following end_of_options as belonging to the flag! - it is potentially an operand to the command + set is_solo_flag 0 + set end_of_options 1 + set end_of_options_index $a_index + #if {[lindex $p 0] eq "tail_processor"} { + $objp allocate $argnum "endofoptions" $a + set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK + incr a_index -1 + #} + } else { + if {($last_arg_was_paramflag) && ([$objp arg_is_defined_solo_to_me $a])} { + #last flag expecting param - but this flag *known* to be solo + #keep it simple and break out at first solo_flag related error ...unless it is trailing flag in the list + lappend argerrors [list flagerror solo_flag_following_non_solo_flag bad_flag $a] + set last_arg_was_solo 1 + break + } + #set is_solo_flag [expr {($a in $solo_flags)}] + #set is_solo_flag [is_this_flag_solo $a $solo_flags $objp] + set is_solo_flag [$objp arg_is_defined_solo_to_me $a] + + if {!$end_of_options} { + if {!$last_arg_was_paramflag} { + if {!$is_solo_flag} { + set is_args_flag [is_candidate_toplevel_param_flag $a $solo_flags $cmdprocessor_records] + #set is_args_flag [string match -* $a] + } + if {$is_args_flag || $is_solo_flag} { + if {[dict get $last_p_found by] eq $processorname} { + if {![is_this_flag_for_me $a $objp $cf_args]} { + if {$processorname ne "globalXXX"} { + do_debug 3 $debugc "----breaking--- $processorname already found a value [dict get $last_p_found item] and has now hit an unrecognized option: $a" + break + } + } + } + } + } else { + #last was flag expecting a param + set is_args_flag 0 + set is_solo_flag 0 + } + } else { + #end_of_options - ignore solo and other flags now. + set is_args_flag 0 + set is_solo_flag 0 + set last_arg_was_paramflag 0 + + } + + #puts stderr "!!!!!!!!!!!!!!!!!!1 here is_args_flag:$is_args_flag" + do_debug 3 $debugc " >________>________>is_p_flag: $is_p_flag last_arg_was_paramflag:$last_arg_was_paramflag is_args_flag:$is_args_flag is_solo: $is_solo_flag (soloflags:$solo_flags) a:$a " + if {!$is_args_flag && !$is_solo_flag } { + + if {!$last_arg_was_paramflag} { + if {[dict get $last_p_found by] eq $processorname} { + if {$processorname ne "tail_processor"} { + #we already found our unflagged value - and now we've hit another - time to break and hand it to a subcommand processor if any + do_debug 3 $debugc "----breaking--- $processorname already found a value [dict get $last_p_found item] and has now hit another value: $a" + break + } + } + set sequence_ok 1 ;#default assumption + set can_allocate [can_this_commandspec_allocate_this_arg $a $p $cf_args] + + if {$can_allocate} { + if {$is_sub} { + #!todo - use v_map as sequence terminator + #check if our find is in sequence + #we are only hunting non-flagged items and the the previous finder removes 1 from the source_values list + #therefore the a_index of our find should be the same if we are processing the very next argument. + #we have already checked that it was a related entity which found the last one. + #todo - review if it matters when parents/siblings don't eat all the way up to the next -flag. + #todo - implement a 'gather' key to keep eating in sequence and accumulate the values as a list + if {$a_index > [dict get $last_p_found index]} { + do_debug 3 $debugc "OUT OF SEQUENCE a_index:$a_index vs last_found index:[dict get $last_p_found index], $processorname disengaging - ignoring value $a and leaving it to the next processor" + set last_arg_was_paramflag 0 + do_debug 3 $debugc "<--- breaking --->" + break + } elseif {$a_index < [dict get $last_p_found index]} { + #too early.... found something before previous match + do_debug 3 $debugc "+++++++++++++++out of sequence $processorname - too early.. keeping scanning" + set sequence_ok 0 + } + if {$sequence_ok} { + set sub_operand 1 + } + } + } + + if {$can_allocate && $sequence_ok} { + #found a non-flagged value in the argumentlist to either reallocate to flagged values or to positional values + if {[dict exists $pinfo dispatch]} { + if {!$is_sub} { + #this must be the arg that caused the match + dict set dispatch $parentname [list command [dict get $pinfo dispatch] matched $a arguments [list] raw [list]] + } else { + #todo + lappend argerrors [list unsupported_dispatch $processorname] + } + } + if {$sub_operand} { + if {[dict exists $dispatch $parentname]} { + #todo - defaults? + add_dispatch_argument "dispatch" $parentname $processorname $a + add_dispatch_raw "dispatch" $parentname $a + } else { + #warning? + #lappend argerrors [list subcommand_unable_to_add_operand $processorname] + do_debug 3 $debugc "subcommand $processorname aborting scanning because parent command wasn't activated" + break + } + } + do_debug 2 $debugc " >+++++++>++++++++>++++++++>setting $processorname [if {$is_p_flag} {list -} {}]value $a" + if {$processorname eq "tail_processor"} { + set argnum [[$objp get_map_object] argnum_from_remaining_posn $a_index] + set argname arg$argnum + lappend remaining_unflagged $argname $a + lappend unconsumed_flags_and_values $a + dict set unflagged $argname $a + } elseif {$is_p_flag} { + $objp set_matched_argument $argnum $a + if {$is_sub} { + dict set extra_flags_from_positionals $p_sub $a + } else { + dict set extra_flags_from_positionals $parentname $a + } + lappend moved_to_flagged $processorname $a + #if has dependent commands ? - check for deep subcommand match? + } else { + $objp set_matched_argument $argnum $a + #lappend positional_values $a + dict set unflagged $processorname $a + } + do_debug 4 $debugc " >________>________>________>source_values :'$source_values'" + do_debug 3 $debugc " >________>________>________>source_values len:[llength $source_values] removing element $a_index val:[lindex $source_values $a_index]" + + #---------------------------- + dict set last_p_found by $processorname + dict set last_p_found index $a_index + dict set last_p_found item $a + #------------------------------ + $objp allocate $argnum "operand" $a + set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK + incr values_index ;#only increment when we allocate a value to one of the members of -commandprocessors + set last_arg_was_paramflag 0 + if {$processorname ne "tail_processor"} { + #don't break until we hit an unrecognized flag or another unflagged value + incr a_index -1 + #don't increment a_index before break, because we have shortened the list by 1. + #do_debug 3 $debugc "----breaking---" + #break + } else { + #decrement to compensate for shortened list because tail_processor continues to end + incr a_index -1 + } + } + + } else { + #last_arg_was_paramflag + set lastarg [dict get $last_p_found item] + #puts stdout "+++ lastarg: $lastarg source_values: [dict get $last_p_found source_values] a_index: $a_index" + if {$processorname eq "tail_processor"} { + lappend unconsumed_flags_and_values $a + } + if {([dict get $last_p_found by] eq $processorname) && [is_this_flag_for_me $lastarg $objp $cf_args]} { + update_dispatch_argument "dispatch" $parentname $lastarg $a + add_dispatch_raw "dispatch" $parentname $a + dict set last_p_found by $processorname + dict set last_p_found index $a_index + dict set last_p_found item $a + $objp allocate $argnum "flagvalue" $a + set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK + incr a_index -1 + } + set last_arg_was_paramflag 0 + } + } else { + # is a flag of some sort ({!$is_args_flag && !$is_solo_flag} = false) + if {$processorname eq "tail_processor"} { + lappend unconsumed_flags_and_values $a + } + if {([dict get $last_p_found by] eq $processorname) && [is_this_flag_for_me $a $objp $cf_args]} { + if {$is_solo_flag} { + add_dispatch_argument "dispatch" $parentname $a 1 + add_dispatch_raw "dispatch" $parentname $a + set last_arg_was_solo 1 + set last_arg_was_paramflag 0 + $objp allocate $argnum "soloflag" $a + } else { + add_dispatch_argument "dispatch" $parentname $a "" + add_dispatch_raw "dispatch" $parentname $a + set last_arg_was_solo 0 + set last_arg_was_paramflag 1 + $objp allocate $argnum "flag" $a + } + dict set last_p_found by $processorname + dict set last_p_found index $a_index + dict set last_p_found item $a + do_debug 4 $debugc " >2_______>________>________>source_values :'$source_values'" + do_debug 3 $debugc " >2_______>________>________>source_values len:[llength $source_values] removing element $a_index val:[lindex $source_values $a_index]" + set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK + incr a_index -1 + } else { + #auto alternate based on last value.. unless end_of_options + if {!$end_of_options} { + if {$a in $solo_flags} { + set last_arg_was_solo 1 + set last_arg_was_paramflag 0 + } else { + set last_arg_was_paramflag 1 + } + } + if {$a_index eq ([llength $source_values]-1)} { + #puts "XXXXXXXXXXXXXXXXXXX $a_index source_values:'$source_values'" + #if at end of list don't retain any last..was info. + set last_arg_was_solo 0 + set last_arg_was_paramflag 0 + } + #skip - don't eat + } + } + } + incr a_index + } + + if {![$objp found_match]} { + + #after break - we have retained vars: $parent, $sub_operand $pinfo $processorname etc + #didn't find an unflagged var - set a default if one was specified. + #do nothing otherwise - check_args will determine if it was -required etc. + #review - should only apply if parent cmd found something? + if {[dict exists $pinfo default]} { + set defaultval [dict get $pinfo default] + if {$is_p_flag} { + if {$is_sub} { + dict set extra_flags_from_positionals $p_sub $defaultval + } else { + dict set extra_flags_from_positionals $processorname $defaultval + } + #lappend moved_to_flagged $processorname $defaultval + lappend implied_flagged $processorname $defaultval + do_debug 3 $debugc "SETTING DEFAULT varname:$processorname $defaultval implied_flagged: $implied_flagged " + } else { + lappend implied_unflagged $processorname $defaultval + dict set unflagged $processorname $defaultval + do_debug 3 $debugc "SETTING DEFAULT varname:$processorname $defaultval moved_to_flagged: $moved_to_flagged " + } + + if {$is_sub && !$sub_operand} { + if {[dict exists $dispatch $parentname]} { + add_dispatch_argument "dispatch" $parentname $processorname $defaultval + } else { + lappend argerrors [list subcommand_unable_to_add_default_operand $processorname $defaultval] + } + } + } + } + + if {[$objp name] eq "tail_processor"} { + $VMAP update_map_from [$objp get_map_object] + } + + if {[llength $argerrors]} { + set parsestatus "error" + #abort processing at first error - we won't be able to make sense of the remaining args anyway + #even the tail_processor won't be able to classify reliably because flag meanings depend on the configured commands + break + } + } + + #assertion - should be none? + #set remaining_values [lrange $source_values $a_index end] + #do_debug 3 $debugc "-------->________>end of processing - remaining vals $remaining_values" + + do_debug 2 $debugc "========>=========>originals : $values" + do_debug 2 $debugc "[$VMAP get_map]" + do_debug 2 $debugc "========>=========>unconsumed: $unconsumed_flags_and_values" + + + + + + set all_flagged [$VMAP get_merged_flagged_by_class *] + set all_flagged_plus [concat $all_flagged $extra_flags_from_positionals] + + set all_flagged_list [$VMAP get_list_flagged_by_class *] + set all_flagged_list [concat $all_flagged_list $extra_flags_from_positionals] + + set remaining_flagged [$VMAP get_merged_flagged_by_class "unallocated"] + + set remaining_flagged_list [$VMAP get_list_flagged_by_class "unallocated"] + + + set unflagged_list_in_processing_order [dict values $unflagged] + set unflagged_list [$VMAP get_list_unflagged_by_class *] + + set unflagged_list_remaining [$VMAP get_list_unflagged_by_class "unallocated"] + + return [dict create \ + listremaining $unconsumed_flags_and_values \ + parseerrors $argerrors \ + parsestatus $parsestatus \ + flagged $all_flagged_plus \ + flaggedlist $all_flagged_list \ + flaggedremaining $remaining_flagged \ + flaggedlistremaining $remaining_flagged_list \ + unflagged $unflagged \ + unflaggedlist $unflagged_list \ + unflaggedremaining $remaining_unflagged \ + unflaggedlistremaining $unflagged_list_remaining \ + flaggednew $extra_flags_from_positionals \ + arglist [concat $unflagged_list_in_processing_order $all_flagged] \ + arglistremaining [concat $unflagged_list_remaining $remaining_flagged] \ + impliedflagged $implied_flagged \ + impliedunflagged $implied_unflagged \ + dispatch $dispatch \ + classifications [$VMAP get_map] \ + gridstring "\n[$VMAP grid]" \ + vmapobject "flagfilter::VMAP_$runid" \ + ] + } + + + + + + + + + + + + #specialisation for collection class to contain commandprocessors + # we expect to use only a single instance of this + oo::class create col_allprocessors { + superclass oolib::collection + variable o_commandspecs + method add_processor {p} { + my add $p [$p name] + if {[$p is_sub]} { + set parentname [$p parentname] + set obj_parent [my item $parentname] + set col_siblings [$obj_parent children] + $col_siblings add $p [$p name] + } + } + method set_commandspecs {cspecs} { + set o_commandspecs $cspecs + } + method get_commandspecs {} { + set o_commandspecs + } + #treating as singleton.. todo tidy + method name_from_record {rec} { + lassign $rec parentname pinfo + if {[dict exists $pinfo sub]} { + set name [join [list $parentname [dict get $pinfo sub]] .] + } else { + set name $parentname + } + return $name + } + method object_from_record {rec} { + set name [my name_from_record $rec] + return [my item $name] + } + #basic check if arg may consume the following one - not based on any specific info from processors + method arg_appears_standalone {f} { + if {(![string match "-*" $f]) && (![string match "/*" $f])} { + #not even flaglike + return 1 + } + if {$f in {- --}} { + return 1 + } + } + #does any processor define it as solo + method flag_can_be_solo {f} { + foreach objp [my items] { + if {[$objp arg_is_defined_solo_to_me $f]} { + return 1 + } + } + return 0 + } + } + oo::class create col_parents { + superclass oolib::collection + method add_parent {p} { + if {[$p is_sub]} { + error "cannot add a sub-processor to the main parents collection" + } + my add $p [$p name] + } + } + #each parent processor has a children collection which can only accept processors with sub defined. + oo::class create col_childprocessors { + superclass oolib::collection + variable o_ownername + method set_owner {parentname} { + set o_ownername $parentname + } + #owner of the collection (a parent processor) + method owner {} { + return $o_ownername + } + method add_processor {p} { + if {![$p is_sub]} { + error "processor must have 'sub' element to add to the parent's collection" + } + #check name matches this parent.. + + my add $p [$p name] + } + } + + oo::class create cprocessor { + variable o_runid + variable o_name + variable o_definition + variable o_pinfo + variable o_parentname + variable o_is_sub + variable o_col_children + variable o_mashopts + variable o_singleopts + variable o_pairopts + variable o_longopts + variable o_found_match ;#we directly matched a command trigger or positional argument + variable o_matched_argument + variable o_matched_argnum + variable o_matchspec + variable o_vmap + constructor {definition runid} { + set o_vmap "" + set o_definition $definition + set o_runid $runid + if {([llength $o_definition] < 2) || ([llength [lindex $o_definition 0]] != 1)} { + error "[self class].constructor Unable to interpret definition '$o_definition'" + } + lassign $o_definition o_parentname o_pinfo + if {([llength $o_pinfo] %2) != 0} { + error "[self class].constructor second element of definition '$o_definition' not a dict" + } + set o_is_sub [dict exists $o_pinfo sub] + if {!$o_is_sub} { + set o_name $o_parentname + set o_col_children [::flagfilter::col_childprocessors new] + $o_col_children set_owner $o_name + } else { + set o_name [join [list $o_parentname [dict get $o_pinfo sub]] .] + } + if {[dict exists $o_pinfo match]} { + set o_matchspec [dict get $o_pinfo match] + } else { + set o_matchspec {^[^-^/].*} ;#match anything that isn't flaglike + } + set o_found_match 0 + set o_matched_argument "" ;#need o_found_match to differentiate match of empty string + set o_matched_argnum -1 + #load mashopts etc at construction time as they're static + set o_mashopts [list] + set o_singleopts [list] + set o_pairopts [list] + set o_longopts [list] + if {[dict exists $o_pinfo mashopts]} { + lappend o_mashopts {*}[dict get $o_pinfo mashopts] + } + if {[dict exists $o_pinfo singleopts]} { + lappend o_singleopts {*}[dict get $o_pinfo singleopts] + } + if {[dict exists $o_pinfo pairopts]} { + lappend o_pairopts {*}[dict get $o_pinfo pairopts] + } + if {[dict exists $o_pinfo longopts]} { + lappend o_longopts {*}[dict get $o_pinfo longopts] + } + } + destructor { + catch {$o_vmap destroy} + if {!$o_is_sub} { + $o_col_children destroy + } + } + + method name {} { + return $o_name + } + #open things up during oo transition.. + method get_def {} { + return $o_definition + } + method is_flag {} { + if {[my is_sub]} { + #sub can be a flag even if parent isn't + set subname [dict get $o_pinfo sub] + return [string match -* $subname] + } else { + return [string match -* $o_name] + } + } + method has_same_parent {other} { + return [expr {[other parentname] eq $o_parentname}] + } + method is_sub {} { + return $o_is_sub + } + + method set_map_object {map} { + set o_vmap $map + } + method get_map_object {} { + return $o_vmap + } + method allocate {argnum type val} { + if {$o_vmap eq ""} { + error "[self class].allocate ($o_name) vmap is not set." + } + $o_vmap allocate [self object] $argnum $type $val + } + + method found_match {} { + return $o_found_match + } + method matched_argument {} { + return $o_matched_argument + } + method matched_argnum {} { + return $o_matched_argnum + } + method set_matched_argument {argnum a} { + #could be empty string + if {$o_found_match} { + error "[self object].set_matched_argument processor:$o_name already found match '$o_matched_argument' - cannot set again" + } + if {![my can_match $a]} { + error "error [self class].set_matched_argument processor:$o_name cannot match '$a' (matchspec: $o_matchspec)" + } + set o_found_match 1 + set o_matched_argument $a + set o_matched_argnum $argnum + } + method has_explicit_matchspec {} { + return [dict exists $o_pinfo match] + } + method matchspec {} { + return $o_matchspec + } + method can_match {a} { + if {!$o_found_match} { + foreach m $o_matchspec { + if {[regexp -- $m $a]} { + return 1 + } + } + return 0 + } else { + return 0 + } + } + #?? + method can_allocate_flags {} { + } + + + + + + #if we are a parent - this is own name + method parentname {} { + return $o_parentname + } + method parent {} { + return [::flagfilter::obj::PARENTS_$o_runid item $o_parentname] + } + method is_parent {} { + return [expr {!$o_is_sub}] + } + method children {} { + if {!$o_is_sub} { + return $o_col_children + } else { + #raise error? + return "" + } + } + method mashopts {} { + return $o_mashopts + } + method singleopts {} { + return $o_singleopts + } + method pairopts {} { + return $o_pairopts + } + method longopts {} { + return $o_longopts + } + + #whether flag categorized as solo by this processor + method arg_is_defined_solo_to_me {a} { + if {(![string match "-*" $a]) && (![string match "/*" $a])} { + #not even flaglike + return 0 + } + if {[my can_match $a]} { + return 0 + } + if {$a in {- --}} { + #specials not defined as solos + return 0 + } + + if {$o_name eq "global"} { + + } elseif {$o_name eq "tail_processor"} { + + } + + if {$a in $o_singleopts} { + return 1 + } + if {"any" in $o_singleopts} { + return 1 + } + set equalposn [string first "=" $a] + if {$equalposn >=1} { + if {"any" in $o_longopts} { + return 1 + } else { + set namepart [string range $a 0 $equalposn-1] + foreach lo $o_longopts { + if {[string match "${namepart}=*" $lo]} { + return 1 + } + } + } + } + #Flag could still be part of a solo if it is in mashopts *and* has a value following it as part of the mash + #- but if it's a pairopt, but not mashable - we can rule it out now + if {($a in $o_pairopts) && ($a ni $o_mashopts)} { + return 0 + } + set flagletters [split [string range $a 1 end] ""] + set posn 1 + #trailing letters may legitimately not be in mashopts if they are part of a mashed value + #we can return 0 if we hit a non-mash flag first.. but at each mashflag we need to test if we can classify as definitely solo or not, or else keep processing + foreach l $flagletters { + if {"-$l" ni $o_mashopts} { + #presumably an ordinary flag not-known to us + return 0 + } else { + if {"-$l" in $o_pairopts} { + if {$posn == [llength $flagletters]} { + #in pairopts and mash - but no value for it in the mash - thefore not a solo + return 0 + } else { + #entire tail is the value - this letter is effectively solo + return 1 + } + } elseif {"-$l" in $o_singleopts} { + #not allowed to take a value - keep processing letters + } else { + #can take a value! but not if at very end of mash. Either way This is a solo + return 1 + } + } + } + #This object should not treat the flag as a known solo + #- so if it is allowed to consume it, it may fall back on examining the subsequent argument's flaginess(?) + return 0 + } + + + method get_opts {} { + return [list mashopts $o_mashopts singleopts $o_singleopts pairopts $o_pairopts longopts $o_longopts] + } + #include parent opts + #we use the terminology 'option' for "-" prefixed items belonging to a -commandprocessors spec as opposed to more general -flags + #Note - this may also be called on the default "tail_processor", which will return empty sets, or an overridden tail_processor which may have data + method get_combined_opts {} { + set objparent [::flagfilter::obj::PARENTS_$o_runid item $o_parentname] + set parentopts [$objparent get_opts] + set mashopts [dict get $parentopts mashopts] + set singleopts [dict get $parentopts singleopts] + set pairopts [dict get $parentopts pairopts] + set longopts [dict get $parentopts longopts] + if {[my is_sub]} { + #this spec is a sub + set subopts [my get_opts] + #does order matter? could use struct::set union ? + foreach m [dict get $subopts mashopts] { + if {$m ni $mashopts} { + lappend mashopts $m + } + } + foreach s [dict get $subopts singleopts] { + if {$s ni $singleopts} { + lappend singleopts $s + } + } + foreach po [dict get $subopts pairopts] { + if {$po ni $pairopts} { + lappend pairopts $po + } + } + foreach lo [dict get $subopts longopts] { + if {$lo ni $longopts} { + lappend longopts $lo + } + } + + } + return [list mashopts $mashopts singleopts $singleopts pairopts $pairopts longopts $longopts] + } + + } + + + + + + + + + + + + proc get_command_info {cmdname cspecs} { + foreach item $cspecs { + lassign $item cmd specinfo + if {$cmd eq $cmdname && [dict exists $specinfo dispatch]} { + return $specinfo + } + } + return [list] + } + #### check_flags + # does not support unvalued flags - unless explicitly specified in -soloflags (global) or in -singleopts for a commandprocessor + #e.g not supported: v1 v2 -arg1 arg1val -debug -anotherflag anotherflagval + # - unless -soloflags is something like -soloflags {-debug} or -soloflags {{-debug 1}} where 1 is the default. In this case - we can no longer support accepting a value for -soloflags - the processor will not assign it an argument from the commandline. + #e.g not supported (unless -debug in -soloflags): v1 v2 -arg1 arg1val -anotherflag anotherflagval -debug + #e.g supported: v2 v2 -arg1 arg1val -debug 1 -anotherflag anotherflagval + # supports positional arguments - but only if specified in -commandprocessors + # todo + # - supports -- for treating following arg as value even if it looks like a flag + # - supports - for reading stdin + # expects at least -values + # other options -caller -defaults -required -extras -commandprocessors + # -soloflags (these are flags that *must* be solo - ie they cannot take an argument ) if no default specified they are boolean defaulting to 1, repeated instances in -values will be appended to a list. + # The only flag that can be a mix of solo or not, is the very last flag in the values list. In this case it must not be in the -soloflags list, but it will default to a boolean 1 to indicate presence. + proc check_flags {args} { + set runid [flagfilter::get_new_runid] + #################################################### + #puts "Entered checkflags, args $args" + set distanceToTop [info level] + set callerlist [list] + set was_dispatched_by_another 0 ;#used to + for {set i 1} {$i < $distanceToTop} {incr i} { + set callerlevel [expr {$distanceToTop - $i}] + set callerinfo [info level $callerlevel] + set firstword [lindex $callerinfo 0] + if {[string match "*check_flags*" $firstword]} { + set was_dispatched_by_another 1 + } + lappend callerlist $firstword + } + #puts stdout "callerlist: $callerlist" + + #first handle args for check_flags itself + if {[catch {lindex [info level -1] 0} caller]} { + set caller "" + } + #puts stderr ">>>>check_flags caller $caller" + get_one_paired_flag_value {-x 1} -x ;# + + #manually check for -caller even if unbalanced args + #we only need to use get_one_paired_flag_value because we haven't yet checked args is a properly formed paired list and if -caller is present we want to use it for clearer error messages. + #use normal dict operations to retrieve other flags. + #if failed to retrieve.. fall through to checks below + if {![catch {get_one_paired_flag_value $args -caller} flag_value_result]} { + set caller $flag_value_result + } + #puts stderr ">>>>check_flags caller $caller" + + + + + set cf_defaults [dict create\ + -caller $caller\ + -return [list arglistremaining]\ + -match [list]\ + -commandprocessors [list]\ + -soloflags [list]\ + -extras [list]\ + -defaults [list]\ + -required [list]\ + -values \uFFFF\ + -debugargs 0\ + ] + dict set cf_defaults -debugargsonerror 1 ;#error level to use when dispatch error occurs.. will not set lower than -debugargs + + + + if {([llength $args] % 2) != 0} { + do_error "check_flags error when called from '$caller' :check_flags must be called with even number of arguments of form: -flag value Valid flags are: '[dict keys $cf_defaults]' \n got: $args" + } + set cf_args $cf_defaults + foreach {k v} $args { + switch -- $k { + -caller - -return - -match - -commandprocessors - -soloflags - -extras - -defaults - -required - -values - -debugargs - -debugargsonerror { + dict set cf_args $k $v + } + default { + do_error "check_flags error when called from ${caller}: Unknown option '$k': must be one of '[dict keys $cf_defaults]' \nIf calling check_flags directly, put args being checked in -values {...}" + } + } + } + unset args + #################################################### + #now look at -values etc that check_flags is checking + + set caller [dict get $cf_args -caller] + + set debugargs [dict get $cf_args -debugargs] + dict set debugc -debugargs [dict get $cf_args -debugargs] + dict set debugc -source "check_flags $caller" + do_debug 1 $debugc "DEBUG-START $caller" + + set returnkey [dict get $cf_args -return] + set defaults [dict get $cf_args -defaults] + if {([llength $defaults] % 2) != 0} { + do_error "check_flags error when called from '$caller' :-defaults must be a list containing an even number of arguments of form: -flag value'" + } + set required [dict get $cf_args -required] + + + set acceptextra [dict get $cf_args -extras] + + set supplied [string trim [dict get $cf_args -values]] + set soloflags [dict get $cf_args -soloflags] ;#By their nature - solo flags are unlikely to be automatically 'required' - review + set solos_with_defaults [list] + foreach solo_spec $soloflags { + if {[llength $solo_spec] == 1} { + lappend solos_with_defaults $solo_spec 1 + } else { + lappend solos_with_defaults [lindex $solo_spec 0] [lindex $solo_spec 1] + } + + } + + if {$debugargs >= 3} { + set prefix "| $caller>" + puts -nonewline stderr "$prefix [string repeat - 30]\n" + puts -nonewline stderr "$prefix input\n" + puts -nonewline stderr "$prefix [string repeat - 30]\n" + #puts stderr "$caller $cf_args" + dict for {k v} $cf_args { + if {$k ne "-commandprocessors"} { + puts -nonewline stderr "$prefix \[$k\]\n" + puts -nonewline stderr "$prefix $v\n" + } + } + if {$debugargs >=4} { + puts -nonewline stderr "$prefix \[-commandprocessors\]\n" + foreach record [dict get $cf_args -commandprocessors] { + puts -nonewline stderr "$prefix $record\n" + } + } + puts -nonewline stderr "$prefix [string repeat - 30]\n" + #dict for {key val} $cf_args { + # puts stderr " $key" + # puts stderr " $val" + #} + } + + + ################################################################################################## + # allocate_arguments does the main work of processing non-flagged items in the main supplied argument list into flagged versions depending on the specs in -commandprocessors + # It sets defaults only for those arguments processed by a '-commandprocessors' spec. + # We must supply it with the -soloflags info because the solo flags affect what is considered an operand. + set command_specs [dict get $cf_args -commandprocessors] ;#may be empty list - that's ok - it will still populate the 'flagged' and 'arglist' return-dict members. + + #some of these are keys returned by allocate_arguments + # - some (e.g supplied) are added by check_flags + # This list is the list of -return values that can be used with check_args + set flaginfo_returns [list \ + parseerrors \ + parsestatus \ + flagged \ + flaggedremaining \ + flaggednew \ + unflagged \ + unflaggedremaining \ + unflaggedlistremaining \ + listremaining \ + arglist \ + arglistremaining \ + impliedunflagged \ + impliedflagged \ + classifications \ + gridstring \ + ranges \ + dispatch \ + dispatchstatuslist \ + dispatchresultlist \ + dispatchstatus \ + supplied \ + defaults \ + status \ + vmapobject \ + ] + + set PROCESSORS [col_allprocessors create ::flagfilter::obj::PROCESSORS_$runid] + set PARENTS [col_parents create ::flagfilter::obj::PARENTS_$runid] + + # + #set command_specs [concat [list {global {}}] $command_specs] + lappend command_specs {tail_processor {}} + + foreach cspec $command_specs { + set obj [cprocessor new $cspec $runid] ;#runid gives access to the context-objects PROCESSORS_runid & PARENTS_runid + if {[$obj is_parent]} { + $PARENTS add_parent $obj + } + #do_debug 1 $debugc "CONFIGURING OBJECT for commandprocessor [$obj name]" + $PROCESSORS add_processor $obj + } + do_debug 1 $debugc "ADDED [$PROCESSORS count] processors to main commandprocessor collection" + do_debug 1 $debugc "ADDED [$PARENTS count] processors to the parents collection" + $PROCESSORS set_commandspecs $command_specs + + #allocate_arguments uses the PROCESSORS object + set processed_arguments [allocate_arguments $PROCESSORS $solos_with_defaults $supplied $cf_args $caller] + #set processed_arguments [allocate_arguments {} $supplied] + + set newly_flagged_positionals [dict get $processed_arguments flaggednew] + set unflaggedremaining [dict get $processed_arguments unflaggedremaining] + set unflaggedlistremaining [dict get $processed_arguments unflaggedlistremaining] + set dispatch [dict get $processed_arguments dispatch] + set flaggedremaining [dict get $processed_arguments flaggedremaining] + set RETURNED_VMAP [dict get $processed_arguments vmapobject] + + + + if {$debugargs >= 3} { + set prefix "| $caller>" + puts -nonewline stderr "$prefix [string repeat - 30]\n" + puts -nonewline stderr "$prefix output\n" + puts -nonewline stderr "$prefix [string repeat - 30]\n" + #puts stderr "processed_arguments: $processed_arguments" + dict for {key val} $processed_arguments { + puts -nonewline stderr "$prefix $key\n" + puts -nonewline stderr "$prefix $val\n" + } + puts -nonewline stderr "$prefix [string repeat - 30]\n" + } + + ################################################################################################## + + + + + + if {![llength $newly_flagged_positionals]} { + if {($supplied eq "\uFFFF") || ![llength $supplied]} { + #do_error "check_flags error when called from ${caller}: missing or empty -values" + } + } + + #probably not something to enforce... we might pass on unbalanced lists to other check_args etc. + #if {([llength $supplied] % 2) != 0} { + # do_error "${caller}: Error. $caller must be called with even number of arguments of form: -flag value Valid flags are: '[dict keys $defaults]'\n received values: $supplied" + #} + + + + set new_arg_list [dict get $processed_arguments arglistremaining] + set flagged_list [dict get $processed_arguments flagged] + #set suppliedkeys_with_extrakeys [concat [dict keys $supplied] [dict keys $newly_flagged_positionals]] + #puts stdout "suppliedkeys and new keys: $suppliedkeys_with_extrakeys" + + #todo - add flaggednew to required if all was specified? + #check invalid flags if not indicated in -extras , either explicitly or with 'extra' + set flags_from_required [get_flagged_only $required {}] + #set known_flags [lsort -unique -nocase [concat [dict keys $defaults] $flags_from_required $soloflags]] ;#why -nocase? why should -l and -L collapse to the uppercase version? + set known_flags [punk::lib::lunique_unordered [concat [dict keys $defaults] $flags_from_required $soloflags ]] + foreach spec $command_specs { + lassign $spec parentname pinfo + if {[string match -* $parentname] && $parentname ni $known_flags} { + lappend known_flags $parentname + } + if {[dict exists $pinfo sub]} { + if {[string match -* [dict get $pinfo sub]]} { + lappend known_flags [dict get $pinfo sub] + } + } + } + do_debug 2 $debugc "------------------->known_flags: $known_flags soloflags:$soloflags" + set invalid_flags [list] + if {"all" ni [string tolower $acceptextra]} { + if {"none" in [string tolower $acceptextra]} { + set ok_extras [list] + } elseif {[llength $acceptextra]} { + set ok_extras $acceptextra + } + #todo + #puts stderr " check_flags - temporary disable of checking for invalid flags" + set pairflagged $flagged_list + foreach {f v} $pairflagged { + if {$f ni $acceptextra && $f ni $known_flags} { + lappend invalid_flags $f + } + } + } + if {[llength $invalid_flags]} { + do_error "check_flags $caller error when called from ${caller}: unknown flags '$invalid_flags'" + } + + set calc_required [list] + set keywords_in_required [lsearch -inline -all -not $required -*] + set bad_keywords_in_required [lsearch -regexp -nocase -all -inline -not $keywords_in_required "all|none"] + if {[llength $bad_keywords_in_required]} { + do_error "check_flags error when called from ${caller}: bad flags in '-required' it must be a list of flags of the form -flagname or ONLY one of the keywords 'none' or 'all'" + } + #keywords_in_required now known to be only comprised of (possibly case variant) values of all|none + if {[llength $keywords_in_required] > 1} { + do_error "check_flags error when called from ${caller}: specifying both 'none' and 'all' in -required is not valid, and repeated values are not valid." + } + if {"none" eq [string tolower [lindex $keywords_in_required 0]]} { + set calc_required [list] + } + set flags [lsearch -inline -all $required -*] + + if {[llength $required]} { + if {[lsearch -nocase $keywords_in_required "all"] >= 0} { + #'all' can be present with other flags - and indicates we also require all the flags from -defaults + dict for {k -} $defaults { + if {$k ni $calc_required} { + lappend calc_required $k + } + } + } + } + + set classifications [dict get $processed_arguments classifications] ;#assertion - ordered by numerically increasing key representing positions in supplied argument list + set rangesets [$RETURNED_VMAP get_ranges_from_classifications $classifications] + set ranges [dict get $rangesets -ranges] + set rangesbytype [dict get $rangesets -rangesbytype] ;#unallocated are split into flag,operand and endofoptions - further splitting is easy enough to do by looking up the classifications list for each position in the supplied arg list. + #tailflags are the same for all dispatch items + set tailflagspaired [tailflagspaired $defaults $supplied $classifications $rangesbytype] + + + set dict_supplied [dict create supplied $supplied] + set dict_defaults [dict create defaults $defaults] + set dict_ranges [dict create ranges $ranges] + set dict_rangesbytype [dict create rangesbytype $rangesbytype] + set raise_dispatch_error_instead_of_return "" + set dict_dispatch_results [list dispatchstatuslist [list] dispatchresultlist [list] dispatchstatus "ok"] + #todo - only dispatch if no unallocated args (must get tail_processor to allocate known flags to 'global') + if {[llength $dispatch]} { + set dispatchstatuslist [list] + set dispatchresultlist [list] + set dispatchstatus "ok" + #each dispatch entry is a commandname and dict + #set dispatchrecord [lrange $dispatch 0 1] + set re_argnum {%arg([0-9^%]+)%} + set re_argtake {%argtake([0-9^%]+)%} + set re_dquotedparts {(?:(?:\"[^\"]*\")|(?:\"[^\"]*"))|(?:\S*[^ \"])} ;#for use with regexp -all -inline + #e.g {"a b" 'b x' "x cd "e f" g a} -> {"a b"} 'b x' {"x cd "} e f {" g a} + #dumb-editor rebalancing quote for above comment " + foreach {parentname dispatchrecord} $dispatch { + set commandinfo [get_command_info $parentname $command_specs] + + do_debug 1 $debugc ">>>>>DISPATCHRECORD: $dispatchrecord" + + # e.g lscmd lscmd natsortcommandline_ls lscmd.dir x + + do_debug 2 $debugc "commandinfo for $parentname: $commandinfo" + set command [dict get $dispatchrecord command] + #support for %x% placeholders in dispatchrecord command + set command [string map {%match% %matched%} $command] ;#alias + set command [string map [list %matched% [dict get $dispatchrecord matched]] $command] + + set argnum_indices [regexp -indices -all -inline $re_argnum $command] + if {[llength $argnum_indices]} { + foreach {argx_indices x_indices} $argnum_indices { + #argx eg %arg12% + set argx [string range $command {*}$argx_indices] + set x [string range $command {*}$x_indices] + set command [string map [list $argx [lindex [dict get $dispatchrecord arguments] $x]] $command] + } + } + + set argsreduced [dict get $dispatchrecord arguments] + #set rawparts [regexp -all -inline $re_dquotedparts [dict get $dispatchrecord raw]] + + #review! + #how will this behave differently on unix + package require punk::winrun + set rawparts [punk::winrun::unquote_wintcl [dict get $dispatchrecord raw]] + #set argtake_indices [regexp -indices -all -inline $re_argtake $command] + + + set start 0 + while {[regexp -start $start -indices $re_argtake $command argx_indices x_indices]} { + #argx eg %argtake12% + set argx [string range $command {*}$argx_indices] + set x [string range $command {*}$x_indices] + set argval [lindex [dict get $dispatchrecord arguments] $x] + set replacementlen [string length $argval] + set command [string map [list $argx $argval] $command] + set start [expr {[lindex $argx_indices 0] + $replacementlen}] + set argsreduced [lremove $argsreduced $x] + set rawparts [lremove $rawparts $x] + } + dict set dispatchrecord arguments $argsreduced + if {$start > 0} { + set rawreduced [join $rawparts] + dict set dispatchrecord raw $rawreduced + } + + set argvals [dict get $dispatchrecord arguments] + set matched_operands [list] + set matched_opts [list] + set matched_in_order [list] + set prefix "${parentname}." + set prefixlen [string length $prefix] + foreach {k v} $argvals { + #puts "$$$$ $k" + if {[string equal -length $prefixlen $prefix $k]} { + #key is prefixed with "commandname." + set k [string replace $k 0 $prefixlen-1] + } + #todo - -- ? + if {[string match -* $k]} { + lappend matched_opts $k $v + lappend matched_in_order $k $v + } else { + set kparts [split $k .] + lappend matched_operands $v + lappend matched_in_order $v + } + } + + if {![dict exists $commandinfo dispatchtype]} { + set dispatchtype tcl + } else { + set dispatchtype [dict get $commandinfo dispatchtype] + } + if {![dict exists $commandinfo dispatchglobal]} { + if {$dispatchtype eq "tcl"} { + set dispatchglobal 1 + } else { + set dispatchglobal 0 + } + } else { + set dispatchglobal [dict get $commandinfo dispatchglobal] + } + #generally we only want to dispatch remaining flagged, and only at the tail end.(as opposed to flags occurring between command groups) + # -It doesn't usually make much sense to dispatch remaining unflagged items, and it would be rare to require flags occurring before the command. + #however - there are potential commands such as help, dryrun or maybe an analysis command that may need to see unconsumed operands or even look 'back' at prior items + ##update 2023-03 - we definitely want to look back to prior non-matches when we match on a script e.g tclsh8.6 -someflag etc xxx.tcl scriptarg1 -etc + # if we match and dispatch on *.tcl - then we may need 'tclsh8.6 -someflag etc' as the interpreter (possibly with arguments) to use. + # we may need a 'script' dispatchtype (as well as the option to just pass these prior arguments as additional options for some other dispatchtypes) + # + # todo - add supported dispatchglobal values such as all, pre, post, allpre, allpost, and classifications + # where pre & post are only those occurring directly before and after the command and its args, i.e not extending beyond any prior or subsequent other command. + # classifications would be flagged as -classifications $classifications whereas pre and post would be added directly if specified singly, or flagged with -pre, -post etc if multiple are specified + # Those beginning with 'all' should also be wrapped in flags, because potentially they come from disjointed sections of the argumentlist + # - and we generally shouldn't supply arguments next to each other that weren't contiguous in the original list + # The 1,true,yes,tailflagspaired value is designed for the usecase where a common set of tail flags e.g -debug can apply to any commands matched by the filter. + # tail = all unallocated args after final command, including operands and end-of-options '--' (todo) + # tailflags = all unallocated *contiguous* flags after the final command and final operands. (ie it will deliberately miss flags following last command if there is a later operand) (todo) + # tailflagspaired = same as tailflags, but any solo-flags are defaulted to 1 (flags not merged, so there might be duplicate keys) so that it's a fully paired list + # In other situations - post may make sense to get the very next set of unconsumed arguments. + if {[string tolower $dispatchglobal] in [list 1 true yes tailflagspaired]} { + set command_range_posn [lsearch -index 1 $ranges $parentname] + set extraflags $tailflagspaired + } else { + set extraflags [list] + } + + #jn concat allows $command to itself be a list + ##tcl dispatchtype + dict set dispatchrecord dispatchtype $dispatchtype + switch -- $dispatchtype { + tcl { + do_debug 1 $debugc "DISPATCHING with tcl arg order: $command $matched_operands $matched_opts $extraflags" + #set commandline [list $command {*}$matched_operands {*}$matched_opts {*}$extraflags] + set commandline [concat $command $matched_operands $matched_opts $extraflags] + } + raw { + do_debug 1 $debugc "DISPATCHING with raw args : $command [dict get $dispatchrecord raw]" + #set commandline [list $command {*}[dict get $dispatchrecord raw] {*}$extraflags] + set commandline [concat $command [dict get $dispatchrecord raw] $extraflags] + } + shell { + do_debug 1 $debugc "DISPATCHING with shell args : $command [dict get $dispatchrecord raw]" + #assume the shell arguments are in one quoted string? + set commandline [concat $command [list [dict get $dispatchrecord raw]] $extraflags] + } + default { + #non quoted shell? raw + defaults? + do_debug 1 $debugc "DISPATCHING with given arg order: $command $matched_in_order $extraflags" + #set commandline [list $command {*}$matched_in_order {*}$extraflags] + set commandline [concat $command $matched_in_order $extraflags] + } + } + + dict set dispatchrecord asdispatched $commandline + set dispatchresult "" + set dispatcherror "" + if {![catch {{*}$commandline} cmdresult]} { + set dispatchresult $cmdresult + lappend dispatchstatuslist [list status ok cmd $parentname outputlength [string length $cmdresult]] + lappend dispatchresultlist $cmdresult + } else { + set dispatchstatus "error" + set dispatcherror $cmdresult + #don't add to dispatchresultlist + lappend dispatchstatuslist [list status err cmd $parentname outputlength 0 error $cmdresult] + if {!$was_dispatched_by_another} { + #this is the first (or a direct) call to check_flags - so make sure error gets raised in this proc rather than just storing the error in the data and returning + set raise_dispatch_error_instead_of_return "dispatchstatuslist:\n[join $dispatchstatuslist \n] \nerrinfo:\n $::errorInfo" + dict set dispatchrecord result $dispatchresult + dict set dispatchrecord error $dispatcherror + dict set dispatch $parentname $dispatchrecord + + break + #return -code error "check_flags error during command dispatch:\n$cmdresult" + } + #we've been dispatched from another check_flags - so ok to propagate the error up via the dispatchrecord/dispatchstatuslist + } + dict set dispatchrecord result $dispatchresult + dict set dispatchrecord error $dispatcherror + dict set dispatch $parentname $dispatchrecord + } + + set dict_dispatch_results [list dispatchcaller $caller dispatchstatuslist $dispatchstatuslist dispatchresultlist $dispatchresultlist dispatchstatus $dispatchstatus] + } + #end llength $dispatch + + + set combined [dict merge $dict_defaults $dict_supplied $processed_arguments $dict_ranges $dict_rangesbytype $dict_dispatch_results] + dict set combined dispatch $dispatch ;#update with asdispatched info + if {([dict get $combined parsestatus] eq "ok") && ([dict get $combined dispatchstatus] eq "ok")} { + dict set combined status "ok" + } else { + dict set combined status "error" + } + do_debug 1 $debugc "COMBINED:$combined" + + + set returnkey [string tolower $returnkey] + if {"all" in $returnkey} { + set returnval $combined + #set returnval [dict merge $combined $dict_dispatch_results] + } else { + if {[llength $returnkey] == 1} { + set invalid 0 + #todo - support multiple merge? + set right "" + if {[regexp -all {\|} $returnkey] == 1} { + lassign [split $returnkey |] left right + set joinparts [split $left ,] + } else { + set joinparts [split $returnkey ,] + } + foreach j [concat $joinparts $right] { + if {$j ni $flaginfo_returns} { + set invalid 1 + } + } + set returnval [list] + if {!$invalid} { + foreach j $joinparts { + lappend returnval {*}[dict get $combined $j] + } + if {[string length $right]} { + set returnval [dict merge $returnval $defaults $returnval] + } + } else { + set returnval [list callerrors [list "-return '$returnkey' not valid"]] + } + } else { + set callerrors [list] + set returnval [dict create] + foreach rk $returnkey { + if {$returnkey in $flaginfo_returns} { + dict set returnval $rk [dict get $combined $returnkey] + } else { + lappend callerrors [list "-return '$returnkey' not valid"] + } + } + if {[llength $callerrors]} { + dict set returnval callerrors $callerrors + } + } + } + + do_debug 1 $debugc "[string repeat = 40]" + do_debug 1 $debugc "dispatch_results: $dict_dispatch_results" + do_debug 1 $debugc "[string repeat - 40]" + + if {[string length $raise_dispatch_error_instead_of_return]} { + set errdebug [dict get $cf_args -debugargsonerror] + if {$errdebug > [dict get $cf_args -debugargs]} { + dict set debugc -debugargs $errdebug + } + } + + set debuglevel_return 2 + set debugdict [concat {*}[lmap k [dict keys $combined] {list $k $debuglevel_return}]] ;#create a dict of keys from combined, all defaulted to $debuglevel_return + if {[llength [dict get $combined parseerrors]]} { + dict set debugdict "parseerrors" 0 + } else { + dict set debugdict "parseerrors" 2 + } + dict set debugdict "defaults" 1 + dict set debugdict "supplied" 1 + dict set debugdict "dispatch" 1 + dict set debugdict "ranges" 1 + dict set debugdict "rangesbytype" 1 + dict set debugdict "dispatchstatus" 1 + if {[dict get $combined "status"] eq "ok"} { + dict set debugdict "status" 1 + } else { + dict set debugdict "status" 0 + } + + do_debug 1 $debugc "returning '$returnkey'" + do_debug 1 $debugc "returnval '$returnval'" + if {([llength $returnval] % 2) == 0} { + do_debug 1 $debugc "returnkeys '[dict keys $returnval]'" + } + do_debug 1 $debugc "[string repeat = 40]" + dict for {k v} $combined { + set dlev [dict get $debugdict $k] + switch -- $k { + dispatch { + set col1 [string repeat " " 12] + #process as paired list rather than dict (support repeated commands) + set i 0 + foreach {cmdname cmdinfo} $v { + set field1 [string repeat " " [expr {[string length $cmdname]}]] + set col2_dispatch [string repeat " " [expr {[string length $cmdname] + 15}]] + set j 0 + foreach {ckey cval} $cmdinfo { + + if {$i == 0 && $j == 0} { + set c1 [overtype::left $col1 "dispatch"] + } else { + set c1 [overtype::left $col1 { ... }] + } + + if {$j == 0} { + set f1 [overtype::left $field1 $cmdname] + set c2 [overtype::left $col2_dispatch "$f1 $ckey"] + } else { + set f1 [overtype::left $field1 ...] + set c2 [overtype::left $col2_dispatch "$f1 $ckey"] + } + #leave at debug level 1 - because dispatch is generally important + do_debug $dlev $debugc "${c1}${c2} $cval" + + incr j + } + incr i + } + + #do_debug 1 $debugc "[overtype::left $col1 $k] [lindex $v 0] [list [lindex $v 1]]" + #foreach {nm rem} [lrange $v 2 end] { + # do_debug 1 $debugc "[overtype::left $col1 { ... }] $nm [list $rem]" + #} + } + dispatchresultlist { + set col1 [string repeat " " 25] + set i 0 + foreach dresult $v { + if {$i == 0} { + set c1 [overtype::left $col1 $k] + } else { + set c1 [overtype::left $col1 { ... }] + } + do_debug $dlev $debugc "$c1 $dresult" + incr i + } + } + classifications { + set col1 [string repeat " " 25] + set len [dict size $v] + if {$len == 0} { + do_debug $dlev $debugc "[overtype::left $col1 $k]" + continue + } + set max [expr {$len -1}] + set numlines [expr $len / 3 + 1] + if {($len % 3) == 0} { + incr numlines -1 + } + set j 0 + for {set ln 0} {$ln < $numlines} {incr ln} { + if {$ln == 0} { + set c1 "[overtype::left $col1 $k]" + } else { + set c1 "[overtype::left $col1 { ... }]" + } + set line "" + for {set col 0} {$col < 3} {incr col} { + if {$j <= $max} { + append line "$j [list [dict get $v $j]] " + } + incr j + } + do_debug $dlev $debugc "$c1 [string trim $line]" + } + } + gridstring { + set col1 [string repeat " " 25] + set i 0 + foreach ln [split $v \n] { + if {$i == 0} { + set c1 [overtype::left $col1 $k] + } else { + set c1 [overtype::left $col1 { ... }] + } + do_debug $dlev $debugc "$c1 $ln" + incr i + } + } + default { + set col1 [string repeat " " 25] + do_debug $dlev $debugc "[overtype::left $col1 $k] $v" + } + } + } + + + # --------------------------------- + foreach obj [$PARENTS items] { + catch {$obj destroy} + } + $PARENTS destroy + #puts "PROCESSORS: $PROCESSORS" + foreach obj [$PROCESSORS items] { + catch {$obj destroy} + } + $PROCESSORS destroy + catch {$RETURNED_VMAP destroy} + # --------------------------------- + + do_debug 1 $debugc "[string repeat = 40]" + do_debug 1 $debugc "DEBUG-END $caller" + if {[string length $raise_dispatch_error_instead_of_return]} { + return -code error $raise_dispatch_error_instead_of_return + } + + + return $returnval + } + + proc tailflagspaired {defaults supplied classifications rangesbytype} { + lassign [lindex $rangesbytype end] c tp a b + if {($c eq "unallocated") && ($tp eq "flagtype")} { + set tail_unallocated [lrange $supplied $a $b] + } else { + set tail_unallocated [list] + } + #set extraflags [list] + set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated] + #dict merge based operation can't work if there are solo_flags? + #review + if {[llength $tail_unallocated]} { + for {set i $a} {$i <=$b} {incr i} { + set arginfo [dict get $classifications $i] + lassign $arginfo class ftype v + switch -- $ftype { + flag - flagvalue { + lappend extraflags $v + } + soloflag { + lappend extraflags $v + if {[dict exists $defaults $v]} { + lappend extraflags [dict get $defaults $v] + } else { + lappend extraflags 1 + } + } + } + } + foreach {k v} [dict get $defaults] { + if {$k ni $extraflags} { + lappend extraflags $k $v + } + } + } else { + set extraflags $defaults + } + return $extraflags + } + + proc tailflagspaired1 {defaults supplied classifications rangesbytype} { + lassign [lindex $rangesbytype end] c tp a b + if {($c eq "unallocated") && ($tp eq "flagtype")} { + set tail_unallocated [lrange $supplied $a $b] + } else { + set tail_unallocated [list] + } + #set all_post_unallocated_ranges [lsearch -all -inline -index 0 [lrange $rangesbytype $command_range_posn end] "unallocated"] + + set extraflags [list] + + #set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated] + #dict merge based operation can't work if there are solo_flags with no value set + if {[llength $tail_unallocated]} { + for {set i $a} {$i <=$b} {incr i} { + set arginfo [dict get $classifications $i] + lassign $arginfo class ftype v + switch -- $ftype { + flag - flagvalue { + lappend extraflags $v + } + soloflag { + lappend extraflags $v + if {[dict exists $defaults $v]} { + lappend extraflags [dict get $defaults $v] + } else { + lappend extraflags 1 + } + } + } + } + foreach {k v} [dict get $defaults] { + if {$k ni $extraflags} { + lappend extraflags $k $v + } + } + } else { + set extraflags $defaults + } + + } + + + +} + + +namespace eval flagfilter { + + #punk::lib::dict_merge_ordered + + + + #retrieve *only* names that are dependant on the provided namekey - not the key itself + # (query is sorted by the trailing numerical index which represents order the arguments were processed) + proc flag_array_get_sorted_subs {arrname sep namekey} { + upvar $arrname arr + set allsubs [array names arr ${namekey}.*${sep}name,*] + set rnames [lmap nm $allsubs {string reverse $nm}] + set sorted_rnames [lsort -dictionary $rnames] + set ordered [lmap nm $sorted_rnames {string reverse $nm}] + return $ordered + } + + proc flag_array_get_sorted_siblings {arrname sep namekey} { + #determine parent by looking at dot - but confirm parent name is in array. + + } + + + + #dictionary based lsort of reversed names which are presumed to have a trailing separator of some sort and a number e.g: name,0 name,1 ... name,10 etc. + #use -dictionary to ensure embedded numbers are sorted as integers + proc array_names_sorted_by_tail {arrname nameglob} { + upvar $arrname arr + set matched_names [array names arr $nameglob] + set rnames [lmap nm $matched_names {string reverse $nm}] + set sorted_rnames [lsort -dictionary $rnames] + return [lmap nm $sorted_rnames {string reverse $nm}] + } + + +} + + + + + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/funcl-0.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/funcl-0.1.tm new file mode 100644 index 00000000..e8430fb0 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/funcl-0.1.tm @@ -0,0 +1,325 @@ +package provide funcl [namespace eval funcl { + variable version + set version 0.1 +}] +#funcl = function list (nested call structure) +# +#a basic functional composition o combinator +#o(f,g)(x) == f(g(x)) + +namespace eval funcl { + + #from punk::pipe + proc arg_is_script_shaped {arg} { + if {[string first " " $arg] >= 0} { + return 1 + } elseif {[string first \n $arg] >= 0} { + return 1 + } elseif {[string first ";" $arg] >= 0} { + return 1 + } elseif {[string first \t $arg] >= 0} { + return 1 + } else { + return 0 + } + } + + + proc o args { + set closing [string repeat {]} [expr [llength $args]-1]] + set body "[join $args { [}] \$data $closing" + return $body + } + + proc o_ args { + set body "" + set tails [lrepeat [llength $args] ""] + puts stdout "tails: $tails" + + set end [lindex $args end] + if {[llength $end] == 1 && [arg_is_script_shaped $end]} { + set endfunc [string map " $end" {uplevel 1 [list if 1 ]}] + } else { + set endfunc $end + } + if {[llength $args] == 1} { + return $endfunc + } + + set wrap { [} + append wrap $endfunc + append wrap { ]} + + set i 0 + foreach cmdlist [lrange $args 0 end-1] { + set is_script 0 + if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { + set is_script 1 + set script [lindex $cmdlist 0] + } + set t "" + if {$i > 0} { + append body { [} + } + set posn [lsearch $cmdlist _] + if {$posn <= 0} { + append body $cmdlist + if {$i == ([llength $args]-2)} { + append body " $wrap" + } + #if {$i == [expr {[llength $args] -2}]} { + # #append body " \$data" + # append body " $wrap" + #} + if {$i > 0} { + set t {]} + } + } else { + append body [lrange $cmdlist 0 $posn-1] + if {$i == ([llength $args] -2)} { + #append body " \$data" + append body " $wrap" + } + set t [lrange $cmdlist $posn+1 end] + if {$i > 0} { + append t { ]} + } + } + lset tails $i $t + incr i + } + append body [join [lreverse $tails] " "] + puts stdout "tails: $tails" + + return $body + } + + #review - consider _call -- if count > 1 then they must all be callable cmdlists(?) + # what does it mean to have additional _fn wrapper with no other elements? (no actual function) + #e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}} + # what type indicates running subtrees in parallel vs sequentially? + # any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc. + # + # + # accept or return a funcl (or funcltree if multiple funcls in one commandlist) + # also accept/return a call - return empty list if passed a call + proc next_funcl {funcl_or_tree} { + if {[lindex $funcl_or_tree 0] eq "_call"} { + return [list] + } + if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} { + set funcl $funcl_or_tree + } else { + error "funcltree not implemented" + } + + + set count [lindex $funcl 1] + if {$count == 0} { + #null funcl.. what is it? metadata/placeholder? + return $funcl + } + set indices [lrange $funcl 2 [expr {1 + $count}]] + set i 0 + foreach idx $indices { + if {$i > 0} { + #todo - return a funcltree + error "multi funcl not implemented" + } + set next [lindex $funcl $idx] + incr i + } + + return $next + + } + + #convert a funcl to a tcl script + proc funcl_script {funcl} { + if {![llength $funcl]} { + return "" + } + set body "" + set tails [list] + + set type [lindex $funcl 0] + if {$type ni [list "_fn" "_call"]} { + #todo - handle funcltree + error "type $type not implemented" + } + + + #only count of 1 with index 3 supported(?) + if {$type eq "_call"} { + #leaf + set cmdlist [lindex $funcl 3] + return $cmdlist + } + + #we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times. + #by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?) + # we would still need to maintain state to stitch it back together once returned from a subtree.. + # ie multiple tail parts + set count [lindex $funcl 1] + + if {$count == 1} { + set idx [lindex $funcl 2] + if {$idx == 3} { + set cmdlist_pre [list] + } else { + set cmdlist_pre [lrange $funcl 3 $idx-1] + } + append body $cmdlist_pre + set t [lrange $funcl $idx+1 end] + lappend tails $t + } else { + #?? + error "funcl_script branching not yet supported" + } + + + set get_next 1 + set i 1 + while {$get_next} { + set funcl [next_funcl $funcl] + if {![llength $funcl]} { + set get_next 0 + } + lassign $funcl type count idx ;#todo support count > 1 + if {$type eq "_call"} { + set get_next 0 + } + set t "" + if {$type eq "_call"} { + append body { [} + append body [lindex $funcl $idx] + append body { ]} + } else { + append body { [} + if {$idx == 3} { + set cmdlist_pre [list] + } else { + set cmdlist_pre [lrange $funcl 3 $idx-1] + } + append body $cmdlist_pre + set t [lrange $funcl $idx+1 end] + lappend tails $t + lappend tails { ]} + } + incr i + } + append body [join [lreverse $tails] " "] + #puts stdout "tails: $tails" + + return $body + } + + + interp alias "" o_of "" funcl::o_of_n 1 + + #o_of_n + #tcl list rep o combinator + # + # can take lists of ordinary commandlists, scripts and funcls + # _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg) + # _fn 0 indicates next item is an unwrapped commandlist (terminal command) + # + #o_of is equivalent to o_of_n 1 (1 argument o combinator) + #last n args are passed to the prior function + #e.g for n=1 f a b = f(a(b)) + #e.g for n=2, e f a b = e(f(a b)) + proc o_of_n {n args} { + puts stdout "o_of_n '$args'" + if {$n != 1} { + error "o_of_n only implemented for 1 sub-funcl" + } + set comp [list] ;#composition list + set end [lindex $args end] + if {[lindex $end 0] in {_fn _call}]} { + #is_funcl + set endfunc [lindex $args end] + } else { + if {[llength $end] == 1 && [arg_is_script_shaped $end]} { + #set endfunc [string map [list $end] {uplevel 1 [list if 1 ]}] + set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]] + } else { + set endfunc [list _call 1 3 [list {*}$end]] + } + } + + if {[llength $args] == 1} { + return $endfunc + } + set comp $endfunc + set revlist [lreverse [lrange $args 0 end-1]] + foreach cmdlist $revlist { + puts stderr "o_of_n >>-- $cmdlist" + if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { + set is_script 1 + set script [lindex $cmdlist 0] + set arglist [list data] + + set comp [list _fn 1 6 call_script $script $arglist $comp] + } else { + set posn1 [expr {[llength $cmdlist] + 2 + $n}] + set comp [list _fn $n $posn1 {*}$cmdlist $comp] + } + } + return $comp + } + proc call_script {script argnames args} { + uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]] + } + proc funcl_script_test {scr} { + do_funcl_script_test $scr + } + proc do_funcl_script_test {scr} { + #set j "in do_funcl_script_test" + #set data "xxx" + #puts '$scr' + if 1 $scr + } + + #standard o_ with no script-handling + proc o_plain args { + set body "" + set i 0 + set tails [lrepeat [llength $args] ""] + #puts stdout "tails: $tails" + foreach cmdlist $args { + set t "" + if {$i > 0} { + append body { [} + } + set posn [lsearch $cmdlist _] + if {$posn <= 0} { + append body $cmdlist + if {$i == ([llength $args] -1)} { + append body " \$data" + } + if {$i > 0} { + set t {]} + } + } else { + append body [lrange $cmdlist 0 $posn-1] + if {$i == ([llength $args] -1)} { + append body " \$data" + } + set t [lrange $cmdlist $posn+1 end] + if {$i > 0} { + append t { ]} + } + } + lset tails $i $t + incr i + } + append body [join [lreverse $tails] " "] + #puts stdout "tails: $tails" + + return $body + } + #timings suggest no faster to split out the first item from the cmdlist loop +} + + + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/logger-0.9.5.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/logger-0.9.5.tm new file mode 100644 index 00000000..739e1c91 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/logger-0.9.5.tm @@ -0,0 +1,1297 @@ +# logger.tcl -- +# +# Tcl implementation of a general logging facility. +# +# Copyright (c) 2003 by David N. Welton +# Copyright (c) 2004-2011 by Michael Schlenker +# Copyright (c) 2006,2015 by Andreas Kupries +# +# See the file license.terms. + +# The logger package provides an 'object oriented' log facility that +# lets you have trees of services, that inherit from one another. +# This is accomplished through the use of Tcl namespaces. + + +package require Tcl 8.5 9 +package provide logger 0.9.5 + +namespace eval ::logger { + namespace eval tree {} + namespace export init enable disable services servicecmd import + + # The active services. + variable services {} + + # The log 'levels'. + variable levels [list debug info notice warn error critical alert emergency] + + # The default global log level used for new logging services + variable enabled "debug" + + # Tcl return codes (in numeric order) + variable RETURN_CODES [list "ok" "error" "return" "break" "continue"] +} + +# Try to load msgcat and fall back to format if it fails +if {[catch {package require msgcat}]} { + interp alias {} ::logger::mc {} ::format +} else { + namespace eval ::logger { + namespace import ::msgcat::mc + } +} + +# ::logger::_nsExists -- +# +# Workaround for missing namespace exists in Tcl 8.2 and 8.3. +# + +if {[package vcompare [package provide Tcl] 8.4] < 0} { + proc ::logger::_nsExists {ns} { + expr {![catch {namespace parent $ns}]} + } +} else { + proc ::logger::_nsExists {ns} { + namespace exists $ns + } +} + +# ::logger::_cmdPrefixExists -- +# +# Utility function to check if a given callback prefix exists, +# this should catch all oddities in prefix names, including spaces, +# glob patterns, non normalized namespaces etc. +# +# Arguments: +# prefix - The command prefix to check +# +# Results: +# 1 or 0 for yes or no +# +proc ::logger::_cmdPrefixExists {prefix} { + set cmd [lindex $prefix 0] + set full [namespace eval :: namespace which [list $cmd]] + if {[string equal $full ""]} {return 0} else {return 1} + # normalize namespaces + set ns [namespace qualifiers $cmd] + set cmd ${ns}::[namespace tail $cmd] + set matches [::info commands ${ns}::*] + if {[lsearch -exact $matches $cmd] != -1} {return 1} + return 0 +} + +# ::logger::walk -- +# +# Walk namespaces, starting in 'start', and evaluate 'code' in +# them. +# +# Arguments: +# start - namespace to start in. +# code - code to execute in namespaces walked. +# +# Side Effects: +# Side effects of code executed. +# +# Results: +# None. + +proc ::logger::walk { start code } { + set children [namespace children $start] + foreach c $children { + logger::walk $c $code + namespace eval $c $code + } +} + +proc ::logger::init {service} { + variable levels + variable services + variable enabled + + if {[string length [string trim $service {:}]] == 0} { + return -code error \ + -errorcode [list LOGGER EMPTY_SERVICENAME] \ + [::logger::mc "Service name invalid. May not consist only of : or be empty"] + } + # We create a 'tree' namespace to house all the services, so + # they are in a 'safe' namespace sandbox, and won't overwrite + # any commands. + namespace eval tree::${service} { + variable service + variable levels + variable oldname + variable enabled + } + + lappend services $service + + set [namespace current]::tree::${service}::service $service + set [namespace current]::tree::${service}::levels $levels + set [namespace current]::tree::${service}::oldname $service + set [namespace current]::tree::${service}::enabled $enabled + + namespace eval tree::${service} { + # Callback to use when the service in question is shut down. + variable delcallback [namespace current]::no-op + + # Callback when the loglevel is changed + variable levelchangecallback [namespace current]::no-op + + # State variable to decide when to call levelcallback + variable inSetLevel 0 + + # The currently configured levelcommands + variable lvlcmds + array set lvlcmds {} + + # List of procedures registered via the trace command + variable traceList "" + + # Flag indicating whether or not tracing is currently enabled + variable tracingEnabled 0 + + # We use this to disable a service completely. In Tcl 8.4 + # or greater, by using this, disabled log calls are a + # no-op! + + proc no-op args {} + + proc stdoutcmd {level text} { + variable service + puts "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'" + } + + proc stderrcmd {level text} { + variable service + puts stderr "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'" + } + + + # setlevel -- + # + # This command differs from enable and disable in that + # it disables all the levels below that selected, and + # then enables all levels above it, which enable/disable + # do not do. + # + # Arguments: + # lv - the level, as defined in $levels. + # + # Side Effects: + # Runs disable for the level, and then enable, in order + # to ensure that all levels are set correctly. + # + # Results: + # None. + + + proc setlevel {lv} { + variable inSetLevel 1 + set oldlvl [currentloglevel] + + # do not allow enable and disable to do recursion + if {[catch { + disable $lv 0 + set newlvl [enable $lv 0] + } msg] == 1} { + return -code error -errorcode $::errorCode $msg + } + # do the recursion here + logger::walk [namespace current] [list setlevel $lv] + + set inSetLevel 0 + lvlchangewrapper $oldlvl $newlvl + return + } + + # enable -- + # + # Enable a particular 'level', and above, for the + # service, and its 'children'. + # + # Arguments: + # lv - the level, as defined in $levels. + # + # Side Effects: + # Enables logging for the particular level, and all + # above it (those more important). It also walks + # through all services that are 'children' and enables + # them at the same level or above. + # + # Results: + # None. + + proc enable {lv {recursion 1}} { + variable levels + set lvnum [lsearch -exact $levels $lv] + if { $lvnum == -1 } { + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] + } + + variable enabled + set newlevel $enabled + set elnum [lsearch -exact $levels $enabled] + if {($elnum == -1) || ($elnum > $lvnum)} { + set newlevel $lv + } + + variable service + while { $lvnum < [llength $levels] } { + interp alias {} [namespace current]::[lindex $levels $lvnum] \ + {} [namespace current]::[lindex $levels $lvnum]cmd + incr lvnum + } + + if {$recursion} { + logger::walk [namespace current] [list enable $lv] + } + lvlchangewrapper $enabled $newlevel + set enabled $newlevel + } + + # disable -- + # + # Disable a particular 'level', and below, for the + # service, and its 'children'. + # + # Arguments: + # lv - the level, as defined in $levels. + # + # Side Effects: + # Disables logging for the particular level, and all + # below it (those less important). It also walks + # through all services that are 'children' and disables + # them at the same level or below. + # + # Results: + # None. + + proc disable {lv {recursion 1}} { + variable levels + set lvnum [lsearch -exact $levels $lv] + if { $lvnum == -1 } { + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] + } + + variable enabled + set newlevel $enabled + set elnum [lsearch -exact $levels $enabled] + if {($elnum > -1) && ($elnum <= $lvnum)} { + if {$lvnum+1 >= [llength $levels]} { + set newlevel "none" + } else { + set newlevel [lindex $levels [expr {$lvnum+1}]] + } + } + + while { $lvnum >= 0 } { + + interp alias {} [namespace current]::[lindex $levels $lvnum] {} \ + [namespace current]::no-op + incr lvnum -1 + } + if {$recursion} { + logger::walk [namespace current] [list disable $lv] + } + lvlchangewrapper $enabled $newlevel + set enabled $newlevel + } + + # currentloglevel -- + # + # Get the currently enabled log level for this service. + # + # Arguments: + # none + # + # Side Effects: + # none + # + # Results: + # current log level + # + + proc currentloglevel {} { + variable enabled + return $enabled + } + + # lvlchangeproc -- + # + # Set or introspect a callback for when the logger instance + # changes its loglevel. + # + # Arguments: + # cmd - the Tcl command to call, it is called with two parameters, old and new log level. + # or none for introspection + # + # Side Effects: + # None. + # + # Results: + # If no arguments are given return the current callback cmd. + + proc lvlchangeproc {args} { + variable levelchangecallback + + switch -exact -- [llength [::info level 0]] { + 1 {return $levelchangecallback} + 2 { + if {[::logger::_cmdPrefixExists [lindex $args 0]]} { + set levelchangecallback [lindex $args 0] + } else { + return -code error \ + -errorcode [list LOGGER INVALID_CMD] \ + [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]] + } + } + default { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "Wrong # of arguments. Usage: \${log}::lvlchangeproc ?cmd?"] + } + } + } + + proc lvlchangewrapper {old new} { + variable inSetLevel + + # we are called after disable and enable are finished + if {$inSetLevel} {return} + + # no action if level does not change + if {[string equal $old $new]} {return} + + variable levelchangecallback + # no action if levelchangecallback isn't a valid command + if {[::logger::_cmdPrefixExists $levelchangecallback]} { + catch { + uplevel \#0 [linsert $levelchangecallback end $old $new] + } + } + } + + # logproc -- + # + # Command used to create a procedure that is executed to + # perform the logging. This could write to disk, out to + # the network, or something else. + # If two arguments are given, use an existing command. + # If three arguments are given, create a proc. + # + # Arguments: + # lv - the level to log, which must be one of $levels. + # args - either zero, one or two arguments. + # if zero this returns the current command registered + # if one, this is a cmd name that is called for this level + # if two, these are an argument and proc body + # + # Side Effects: + # Creates a logging command to take care of the details + # of logging an event. + # + # Results: + # If called with zero length args, returns the name of the currently + # configured logging procedure. + # + # + + proc logproc {lv args} { + variable levels + variable lvlcmds + + set lvnum [lsearch -exact $levels $lv] + if { ($lvnum == -1) && ($lv != "trace") } { + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] + } + switch -exact -- [llength $args] { + 0 { + return $lvlcmds($lv) + } + 1 { + set cmd [lindex $args 0] + if {[string equal "[namespace current]::${lv}cmd" $cmd]} {return} + if {[llength [::info commands $cmd]]} { + proc ${lv}cmd args [format { + uplevel 1 [list %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] + } $cmd] + } else { + return -code error \ + -errorcode [list LOGGER INVALID_CMD] \ + [::logger::mc "Invalid cmd '%s' - does not exist" $cmd] + } + set lvlcmds($lv) $cmd + } + 2 { + foreach {arg body} $args {break} + proc ${lv}cmd args [format {\ + _setservicename args + set val [%s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] + _restoreservice + set val} ${lv}customcmd] + proc ${lv}customcmd $arg $body + set lvlcmds($lv) [namespace current]::${lv}customcmd + } + default { + return -code error \ + -errorcode [list LOGGER WRONG_USAGE] \ + [::logger::mc \ + "Usage: \${log}::logproc level ?cmd?\nor \${log}::logproc level argname body" ] + } + } + } + + + # delproc -- + # + # Set or introspect a callback for when the logger instance + # is deleted. + # + # Arguments: + # cmd - the Tcl command to call. + # or none for introspection + # + # Side Effects: + # None. + # + # Results: + # If no arguments are given return the current callback cmd. + + proc delproc {args} { + variable delcallback + + switch -exact -- [llength [::info level 0]] { + 1 {return $delcallback} + 2 { if {[::logger::_cmdPrefixExists [lindex $args 0]]} { + set delcallback [lindex $args 0] + } else { + return -code error \ + -errorcode [list LOGGER INVALID_CMD] \ + [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]] + } + } + default { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "Wrong # of arguments. Usage: \${log}::delproc ?cmd?"] + } + } + } + + + # delete -- + # + # Delete the namespace and its children. + + proc delete {} { + variable delcallback + variable service + + logger::walk [namespace current] delete + if {[::logger::_cmdPrefixExists $delcallback]} { + uplevel \#0 [lrange $delcallback 0 end] + } + # clean up the global services list + set idx [lsearch -exact [logger::services] $service] + if {$idx !=-1} { + set ::logger::services [lreplace [logger::services] $idx $idx] + } + + namespace delete [namespace current] + + } + + # services -- + # + # Return all child services + + proc services {} { + variable service + + set children [list] + foreach srv [logger::services] { + if {[string match "${service}::*" $srv]} { + lappend children $srv + } + } + return $children + } + + # servicename -- + # + # Return the name of the service + + proc servicename {} { + variable service + return $service + } + + proc _setservicename {argname} { + variable service + variable oldname + upvar 1 $argname arg + if {[llength $arg] <= 1} { + return + } + + set count -1 + set newname "" + while {[string equal [lindex $arg [expr {$count+1}]] "-_logger::service"]} { + incr count 2 + set newname [lindex $arg $count] + } + if {[string equal $newname ""]} { + return + } + set oldname $service + set service $newname + # Pop off "-_logger::service " from argument list + set arg [lreplace $arg 0 $count] + } + + proc _restoreservice {} { + variable service + variable oldname + set service $oldname + return + } + + proc trace { action args } { + variable service + + # Allow other boolean values (true, false, yes, no, 0, 1) to be used + # as synonymns for "on" and "off". + + if {[string is boolean $action]} { + set xaction [expr {($action && 1) ? "on" : "off"}] + } else { + set xaction $action + } + + # Check for required arguments for actions/subcommands and dispatch + # to the appropriate procedure. + + switch -- $xaction { + "status" { + return [uplevel 1 [list logger::_trace_status $service $args]] + } + "on" { + if {[llength $args]} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace on\""] + } + return [logger::_trace_on $service] + } + "off" { + if {[llength $args]} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace off\""] + } + return [logger::_trace_off $service] + } + "add" { + if {![llength $args]} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace add ?-ns? ...\""] + } + return [uplevel 1 [list ::logger::_trace_add $service $args]] + } + "remove" { + if {![llength $args]} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc "wrong # args: should be \"trace remove ?-ns? ...\""] + } + return [uplevel 1 [list ::logger::_trace_remove $service $args]] + } + + default { + return -code error \ + -errorcode [list LOGGER INVALID_ARG] \ + [::logger::mc "Invalid action \"%s\": must be status, add, remove,\ + on, or off" $action] + } + } + } + + # Walk the parent service namespaces to see first, if they + # exist, and if any are enabled, and then, as a + # consequence, enable this one + # too. + + enable $enabled + variable parent [namespace parent] + while {[string compare $parent "::logger::tree"]} { + # If the 'enabled' variable doesn't exist, create the + # whole thing. + if { ! [::info exists ${parent}::enabled] } { + logger::init [string range $parent 16 end] + } + set enabled [set ${parent}::enabled] + enable $enabled + set parent [namespace parent $parent] + } + } + + # Now create the commands for different levels. + + namespace eval tree::${service} { + set parent [namespace parent] + + # We 'inherit' the commands from the parents. This + # means that, if you want to share the same methods with + # children, they should be instantiated after the parent's + # methods have been defined. + + variable lvl ; # prevent creative writing to the global scope + if {[string compare $parent "::logger::tree"]} { + foreach lvl [::logger::levels] { + # OPTIMIZE: do not allow multiple aliases in the hierarchy + # they can always be replaced by more efficient + # direct aliases to the target procs. + interp alias {} [namespace current]::${lvl}cmd \ + {} ${parent}::${lvl}cmd -_logger::service $service + } + # inherit the starting loglevel of the parent service + setlevel [${parent}::currentloglevel] + } else { + foreach lvl [concat [::logger::levels] "trace"] { + proc ${lvl}cmd args [format {\ + _setservicename args + set val [stdoutcmd %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] + _restoreservice + set val } $lvl] + + set lvlcmds($lvl) [namespace current]::${lvl}cmd + } + setlevel $::logger::enabled + } + unset lvl ; # drop the temp iteration variable + } + + return ::logger::tree::${service} +} + +# ::logger::services -- +# +# Returns a list of all active services. +# +# Arguments: +# None. +# +# Side Effects: +# None. +# +# Results: +# List of active services. + +proc ::logger::services {} { + variable services + return $services +} + +# ::logger::enable -- +# +# Global enable for a certain level. NOTE - this implementation +# isn't terribly effective at the moment, because it might hit +# children before their parents, who will then walk down the +# tree attempting to disable the children again. +# +# Arguments: +# lv - level above which to enable logging. +# +# Side Effects: +# Enables logging in a given level, and all higher levels. +# +# Results: +# None. + +proc ::logger::enable {lv} { + variable services + if {[catch { + foreach sv $services { + ::logger::tree::${sv}::enable $lv + } + } msg] == 1} { + return -code error -errorcode $::errorCode $msg + } +} + +proc ::logger::disable {lv} { + variable services + if {[catch { + foreach sv $services { + ::logger::tree::${sv}::disable $lv + } + } msg] == 1} { + return -code error -errorcode $::errorCode $msg + } +} + +proc ::logger::setlevel {lv} { + variable services + variable enabled + variable levels + if {[lsearch -exact $levels $lv] == -1} { + return -code error \ + -errorcode [list LOGGER INVALID_LEVEL] \ + [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] + } + set enabled $lv + if {[catch { + foreach sv $services { + ::logger::tree::${sv}::setlevel $lv + } + } msg] == 1} { + return -code error -errorcode $::errorCode $msg + } +} + +# ::logger::levels -- +# +# Introspect the available log levels. Provided so a caller does +# not need to know implementation details or code the list +# himself. +# +# Arguments: +# None. +# +# Side Effects: +# None. +# +# Results: +# levels - The list of valid log levels accepted by enable and disable + +proc ::logger::levels {} { + variable levels + return $levels +} + +# ::logger::servicecmd -- +# +# Get the command token for a given service name. +# +# Arguments: +# service - name of the service. +# +# Side Effects: +# none +# +# Results: +# log - namespace token for this service + +proc ::logger::servicecmd {service} { + variable services + if {[lsearch -exact $services $service] == -1} { + return -code error \ + -errorcode [list LOGGER NO_SUCH_SERVICE] \ + [::logger::mc "Service \"%s\" does not exist." $service] + } + return "::logger::tree::${service}" +} + +# ::logger::import -- +# +# Import the logging commands. +# +# Arguments: +# service - name of the service. +# +# Side Effects: +# creates aliases in the target namespace +# +# Results: +# none + +proc ::logger::import {args} { + variable services + + if {[llength $args] == 0 || [llength $args] > 7} { + return -code error \ + -errorcode [list LOGGER WRONG_NUM_ARGS] \ + [::logger::mc \ + "Wrong # of arguments: \"logger::import ?-all?\ + ?-force?\ + ?-prefix prefix? ?-namespace namespace? service\""] + } + + # process options + # + set import_all 0 + set force 0 + set prefix "" + set ns [uplevel 1 namespace current] + while {[llength $args] > 1} { + set opt [lindex $args 0] + set args [lrange $args 1 end] + switch -exact -- $opt { + -all { set import_all 1} + -prefix { set prefix [lindex $args 0] + set args [lrange $args 1 end] + } + -namespace { + set ns [lindex $args 0] + set args [lrange $args 1 end] + } + -force { + set force 1 + } + default { + return -code error \ + -errorcode [list LOGGER UNKNOWN_ARG] \ + [::logger::mc \ + "Unknown argument: \"%s\" :\nUsage:\ + \"logger::import ?-all? ?-force?\ + ?-prefix prefix? ?-namespace namespace? service\"" $opt] + } + } + } + + # + # build the list of commands to import + # + + set cmds [logger::levels] + lappend cmds "trace" + if {$import_all} { + lappend cmds setlevel enable disable logproc delproc services + lappend cmds servicename currentloglevel delete + } + + # + # check the service argument + # + + set service [lindex $args 0] + if {[lsearch -exact $services $service] == -1} { + return -code error \ + -errorcode [list LOGGER NO_SUCH_SERVICE] \ + [::logger::mc "Service \"%s\" does not exist." $service] + } + + # + # setup the namespace for the import + # + + set sourcens [logger::servicecmd $service] + set localns [uplevel 1 namespace current] + + if {[string match ::* $ns]} { + set importns $ns + } else { + set importns ${localns}::$ns + } + + # fake namespace exists for Tcl 8.2 - 8.3 + if {![_nsExists $importns]} { + namespace eval $importns {} + } + + + # + # prepare the import + # + + set imports "" + foreach cmd $cmds { + set cmdname ${importns}::${prefix}$cmd + set collision [llength [info commands $cmdname]] + if {$collision && !$force} { + return -code error \ + -errorcode [list LOGGER IMPORT_NAME_EXISTS] \ + [::logger::mc "can't import command \"%s\": already exists" $cmdname] + } + lappend imports ${importns}::${prefix}$cmd ${sourcens}::${cmd} + } + + # + # and execute the aliasing after checking all is well + # + + foreach {target source} $imports { + proc $target {args} "uplevel 1 \[linsert \$args 0 $source \]" + } +} + +# ::logger::initNamespace -- +# +# Creates a logger for the specified namespace and makes the log +# commands available to said namespace as well. Allows the initial +# setting of a default log level. +# +# Arguments: +# ns - Namespace to initialize, is also the service name, modulo a ::-prefix +# level - Initial log level, optional, defaults to 'warn'. +# +# Side Effects: +# creates aliases in the target namespace +# +# Results: +# none + +proc ::logger::initNamespace {ns {level {}}} { + set service [string trimleft $ns :] + if {$level == ""} { + # No user-specified level. Figure something out. + # - If the parent service exists then the 'logger::init' + # below will automatically inherit its level. Good enough. + # - Without a parent service go and use a default level of 'warn'. + set parent [string trimleft [namespace qualifiers $service] :] + set hasparent [expr {($parent != {}) && [_nsExists ::logger::tree::${parent}]}] + if {!$hasparent} { + set level warn + } + } + + namespace eval $ns [list ::logger::init $service] + namespace eval $ns [list ::logger::import -force -all -namespace log $service] + if {$level != ""} { + namespace eval $ns [list log::setlevel $level] + } + return +} + +# This procedure handles the "logger::trace status" command. Given no +# arguments, returns a list of all procedures that have been registered +# via "logger::trace add". Given one or more procedure names, it will +# return 1 if all were registered, or 0 if any were not. + +proc ::logger::_trace_status { service procList } { + upvar #0 ::logger::tree::${service}::traceList traceList + + # If no procedure names were given, just return the registered list + + if {![llength $procList]} { + return $traceList + } + + # Get caller's namespace for qualifying unqualified procedure names + + set caller_ns [uplevel 1 namespace current] + set caller_ns [string trimright $caller_ns ":"] + + # Search for any specified proc names that are *not* registered + + foreach procName $procList { + # Make sure the procedure namespace is qualified + + if {![string match "::*" $procName]} { + set procName ${caller_ns}::$procName + } + + # Check if the procedure has been registered for tracing + + if {[lsearch -exact $traceList $procName] == -1} { + return 0 + } + } + + return 1 +} + +# This procedure handles the "logger::trace on" command. If tracing +# is turned off, it will enable Tcl trace handlers for all of the procedures +# registered via "logger::trace add". Does nothing if tracing is already +# turned on. + +proc ::logger::_trace_on { service } { + set tcl_version [package provide Tcl] + + if {[package vcompare $tcl_version "8.4"] < 0} { + return -code error \ + -errorcode [list LOGGER TRACE_NOT_AVAILABLE] \ + [::logger::mc "execution tracing is not available in Tcl %s" $tcl_version] + } + + namespace eval ::logger::tree::${service} { + if {!$tracingEnabled} { + set tracingEnabled 1 + ::logger::_enable_traces $service $traceList + } + } + + return 1 +} + +# This procedure handles the "logger::trace off" command. If tracing +# is turned on, it will disable Tcl trace handlers for all of the procedures +# registered via "logger::trace add", leaving them in the list so they +# tracing on all of them can be enabled again with "logger::trace on". +# Does nothing if tracing is already turned off. + +proc ::logger::_trace_off { service } { + namespace eval ::logger::tree::${service} { + if {$tracingEnabled} { + ::logger::_disable_traces $service $traceList + set tracingEnabled 0 + } + } + + return 1 +} + +# This procedure is used by the logger::trace add and remove commands to +# process the arguments in a common fashion. If the -ns switch is given +# first, this procedure will return a list of all existing procedures in +# all of the namespaces given in remaining arguments. Otherwise, each +# argument is taken to be either a pattern for a glob-style search of +# procedure names or, failing that, a namespace, in which case this +# procedure returns a list of all the procedures matching the given +# pattern (or all in the named namespace, if no procedures match). + +proc ::logger::_trace_get_proclist { inputList } { + set procList "" + + if {[string equal [lindex $inputList 0] "-ns"]} { + # Verify that at least one target namespace was supplied + + set inputList [lrange $inputList 1 end] + if {![llength $inputList]} { + return -code error \ + -errorcode [list LOGGER TARGET_MISSING] \ + [::logger::mc "Must specify at least one namespace target"] + } + + # Rebuild the argument list to contain namespace procedures + + foreach namespace $inputList { + # Don't allow tracing of the logger (or child) namespaces + + if {![string match "::logger::*" $namespace]} { + set nsProcList [::info procs ${namespace}::*] + set procList [concat $procList $nsProcList] + } + } + } else { + # Search for procs or namespaces matching each of the specified + # patterns. + + foreach pattern $inputList { + set matches [uplevel 1 ::info proc $pattern] + + if {![llength $matches]} { + if {[uplevel 1 namespace exists $pattern]} { + set matches [::info procs ${pattern}::*] + } + + # Matched procs will be qualified due to above pattern + + set procList [concat $procList $matches] + } elseif {[string match "::*" $pattern]} { + # Patterns were pre-qualified - add them directly + + set procList [concat $procList $matches] + } else { + # Qualify each proc with the namespace it was in + + set ns [uplevel 1 namespace current] + if {$ns == "::"} { + set ns "" + } + foreach proc $matches { + lappend procList ${ns}::$proc + } + } + } + } + + return $procList +} + +# This procedure handles the "logger::trace add" command. If the tracing +# feature is enabled, it will enable the Tcl entry and leave trace handlers +# for each procedure specified that isn't already being traced. Each +# procedure is added to the list of procedures that the logger trace feature +# should log when tracing is enabled. + +proc ::logger::_trace_add { service procList } { + upvar #0 ::logger::tree::${service}::traceList traceList + + # Handle -ns switch and glob search patterns for procedure names + + set procList [uplevel 1 [list logger::_trace_get_proclist $procList]] + + # Enable tracing for each procedure that has not previously been + # specified via logger::trace add. If tracing is off, this will just + # store the name of the procedure for later when tracing is turned on. + + foreach procName $procList { + if {[lsearch -exact $traceList $procName] == -1} { + lappend traceList $procName + ::logger::_enable_traces $service [list $procName] + } + } +} + +# This procedure handles the "logger::trace remove" command. If the tracing +# feature is enabled, it will remove the Tcl entry and leave trace handlers +# for each procedure specified. Each procedure is removed from the list +# of procedures that the logger trace feature should log when tracing is +# enabled. + +proc ::logger::_trace_remove { service procList } { + upvar #0 ::logger::tree::${service}::traceList traceList + + # Handle -ns switch and glob search patterns for procedure names + + set procList [uplevel 1 [list logger::_trace_get_proclist $procList]] + + # Disable tracing for each proc that previously had been specified + # via logger::trace add. If tracing is off, this will just + # remove the name of the procedure from the trace list so that it + # will be excluded when tracing is turned on. + + foreach procName $procList { + set index [lsearch -exact $traceList $procName] + if {$index != -1} { + set traceList [lreplace $traceList $index $index] + ::logger::_disable_traces $service [list $procName] + } + } +} + +# This procedure enables Tcl trace handlers for all procedures specified. +# It is used both to enable Tcl's tracing for a single procedure when +# removed via "logger::trace add", as well as to enable all traces +# via "logger::trace on". + +proc ::logger::_enable_traces { service procList } { + upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled + + if {$tracingEnabled} { + foreach procName $procList { + ::trace add execution $procName enter \ + [list ::logger::_trace_enter $service] + ::trace add execution $procName leave \ + [list ::logger::_trace_leave $service] + } + } +} + +# This procedure disables Tcl trace handlers for all procedures specified. +# It is used both to disable Tcl's tracing for a single procedure when +# removed via "logger::trace remove", as well as to disable all traces +# via "logger::trace off". + +proc ::logger::_disable_traces { service procList } { + upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled + + if {$tracingEnabled} { + foreach procName $procList { + ::trace remove execution $procName enter \ + [list ::logger::_trace_enter $service] + ::trace remove execution $procName leave \ + [list ::logger::_trace_leave $service] + } + } +} + +######################################################################## +# Trace Handlers +######################################################################## + +# This procedure is invoked upon entry into a procedure being traced +# via "logger::trace add" when tracing is enabled via "logger::trace on" +# to log information about how the procedure was called. + +proc ::logger::_trace_enter { service cmd op } { + # Parse the command + set procName [uplevel 1 namespace origin [lindex $cmd 0]] + set args [lrange $cmd 1 end] + + # Display the message prefix + set callerLvl [expr {[::info level] - 1}] + set calledLvl [::info level] + + lappend message "proc" $procName + lappend message "level" $calledLvl + lappend message "script" [uplevel ::info script] + + # Display the caller information + set caller "" + if {$callerLvl >= 1} { + # Display the name of the caller proc w/prepended namespace + catch { + set callerProcName [lindex [::info level $callerLvl] 0] + set caller [uplevel 2 namespace origin $callerProcName] + } + } + + lappend message "caller" $caller + + # Display the argument names and values + set argSpec [uplevel 1 ::info args $procName] + set argList "" + if {[llength $argSpec]} { + foreach argName $argSpec { + lappend argList $argName + + if {$argName == "args"} { + lappend argList $args + break + } else { + lappend argList [lindex $args 0] + set args [lrange $args 1 end] + } + } + } + + lappend message "procargs" $argList + set message [list $op $message] + + ::logger::tree::${service}::tracecmd $message +} + +# This procedure is invoked upon leaving into a procedure being traced +# via "logger::trace add" when tracing is enabled via "logger::trace on" +# to log information about the result of the procedure call. + +proc ::logger::_trace_leave { service cmd status rc op } { + variable RETURN_CODES + + # Parse the command + set procName [uplevel 1 namespace origin [lindex $cmd 0]] + + # Gather the caller information + set callerLvl [expr {[::info level] - 1}] + set calledLvl [::info level] + + lappend message "proc" $procName "level" $calledLvl + lappend message "script" [uplevel ::info script] + + # Get the name of the proc being returned to w/prepended namespace + set caller "" + catch { + set callerProcName [lindex [::info level $callerLvl] 0] + set caller [uplevel 2 namespace origin $callerProcName] + } + + lappend message "caller" $caller + + # Convert the return code from numeric to verbal + + if {$status < [llength $RETURN_CODES]} { + set status [lindex $RETURN_CODES $status] + } + + lappend message "status" $status + lappend message "result" $rc + + # Display the leave message + + set message [list $op $message] + ::logger::tree::${service}::tracecmd $message + + return 1 +} + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/metaface-1.2.5.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/metaface-1.2.5.tm new file mode 100644 index 00000000..ebcf579e --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/metaface-1.2.5.tm @@ -0,0 +1,6411 @@ +package require dictutils +package provide metaface [namespace eval metaface { + variable version + set version 1.2.5 +}] + + + + +#example datastructure: +#$_ID_ +#{ +#i +# { +# this +# { +# {16 ::p::16 item ::>x {}} +# } +# role2 +# { +# {17 ::p::17 item ::>y {}} +# {18 ::p::18 item ::>z {}} +# } +# } +#context {} +#} + +#$MAP +#invocantdata {16 ::p::16 item ::>x {}} +#interfaces {level0 +# { +# api0 {stack {123 999}} +# api1 {stack {333}} +# } +# level0_default api0 +# level1 +# { +# } +# level1_default {} +# } +#patterndata {patterndefaultmethod {}} + + +namespace eval ::p::predator {} +#temporary alternative to ::p::internals namespace. +# - place predator functions here until ready to replace internals. + + +namespace eval ::p::snap { + variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks. +} + + + + +# not called directly. Retrieved using 'info body ::p::predator::getprop_template' +#review - why use a proc instead of storing it as a string? +proc ::p::predator::getprop_template {_ID_ args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args]} { + #lassign [lindex $invocant 0] OID alias itemCmd cmd + if {[array exists ${ns}::o_%prop%]} { + #return [set ${ns}::o_%prop%($args)] + if {[llength $args] == 1} { + return [set ::p::${OID}::o_%prop%([lindex $args 0])] + } else { + return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]] + } + } else { + set val [set ${ns}::o_%prop%] + + set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] + if {$rType eq "object"} { + #return [$val . item {*}$args] + return [$val {*}$args] + } else { + #treat as list? + return [lindex $val $args] + } + } + } else { + return [set ${ns}::o_%prop%] + } +} + + +proc ::p::predator::getprop_template_immediate {_ID_ args} { + if {[llength $args]} { + if {[array exists %ns%::o_%prop%]} { + return [set %ns%::o_%prop%($args)] + } else { + set val [set %ns%::o_%prop%] + set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] + if {$rType eq "object"} { + #return [$val . item {*}$args] + #don't assume defaultmethod named 'item'! + return [$val {*}$args] + } else { + #treat as list? + return [lindex $val $args] + } + } + } else { + return [set %ns%::o_%prop%] + } +} + + + + + + + + +proc ::p::predator::getprop_array {_ID_ prop args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + + #upvar 0 ::p::${OID}::o_${prop} prop + #1st try: assume array + if {[catch {array get ::p::${OID}::o_${prop}} result]} { + #treat as list (why?) + #!review + if {[info exists ::p::${OID}::o_${prop}]} { + array set temp [::list] + set i 0 + foreach element ::p::${OID}::o_${prop} { + set temp($i) $element + incr i + } + set result [array get temp] + } else { + error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" + } + } + return $result +} + +proc ::p::predator::setprop_template {prop _ID_ args} { + set OID [lindex [dict get $_ID_ i this] 0 0] + if {"%varspace%" eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" "%varspace%"]} { + set ns "%varspace%" + } else { + set ns ::p::${OID}::%varspace% + } + } + + + if {[llength $args] == 1} { + #return [set ::p::${OID}::o_%prop% [lindex $args 0]] + return [set ${ns}::o_%prop% [lindex $args 0]] + + } else { + if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { + #treat attempt to perform indexed write to nonexistant var, same as indexed write to array + + #2 args - single index followed by a value + if {[llength $args] == 2} { + return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] + } else { + #multiple indices + #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] + return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] + } + } else { + #treat as list + return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] + } + } +} + +#-------------------------------------- +#property read & write traces +#-------------------------------------- + + +proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} { + + #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' " + + #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain. + + if {[llength $idx]} { + if {[llength $idx] == 1} { + set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx] + } else { + lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx] + } + return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value + } else { + if {![info exists $refname]} { + set $refname [$get_cmd $_ID_ {*}$indices] + } else { + set newval [$get_cmd $_ID_ {*}$indices] + if {[set $refname] ne $newval} { + set $refname $newval + } + } + return + } +} + + + + +proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} { + #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" + + + #derive the name of the write command from the ref var. + set indices [lassign [split [namespace tail $refname] +] prop] + + + #assert - we will never have both a list in indices and an idx value + if {[llength $indices] && ($idx ne "")} { + #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x + #review - are there any datastructures which would/should allow this? + #this assertion is really just here as a sanity check for now + error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" + } + + #upvar #0 ::p::${OID}::_meta::map MAP + #puts "-->propref_trace_write map: $MAP" + + #temporarily deactivate refsync trace + #puts stderr -->1>--removing_trace_o_${field} +### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + #we need to catch, and re-raise any error that we may receive when writing the property + # because we have to reinstate the propvar_write_TraceHandler after the call. + #(e.g there may be a propertywrite handler that deliberately raises an error) + + set excludesync_refs $refname + set cmd ::p::${OID}::(SET)$prop + + + set f_error 0 + if {[catch { + + if {![llength $indices]} { + if {[string length $idx]} { + $cmd $_ID_ $idx [set ${refname}($idx)] + #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] + + } else { + $cmd $_ID_ [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] + } + } else { + #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" + $cmd $_ID_ {*}$indices [set $refname] + ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices + } + + } result]} { + set f_error 1 + } + + + + + #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write + #reactivate refsync trace + #puts stderr "****** reactivating refsync trace on o_$field" + #puts stderr -->2>--reactivating_trace_o_${field} + ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] + + + if {$f_error} { + #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. + # ? return -code error $errMsg ? -errorinfo + + #!quick n dirty + #error $errorMsg + return -code error -errorinfo $::errorInfo $result + } else { + return $result + } +} + + + + + +proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { + #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'" + #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array') + + set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set + + #set updated_value [::p::predator::getprop_array $prop $_ID_] + #puts stderr "-->array_Trace updated_value:$updated_value" + if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} { + puts stderr "-->propref_trace_array error $errm" + array set $refname {} + } + + #return value ignored for +} + + +#-------------------------------------- +# +proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + + + #don't rely on variable name passed by trace - may have been 'upvar'ed + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar" + + set iflist [dict get $MAP interfaces level0] + + set plist [list] + + #!todo - get propertylist from cache on object(?) + foreach IFID [lreverse $iflist] { + dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { + #lassign $pdef v + if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} { + if {[array exists ::p::${OID}::o_${prop}]} { + lappend plist $prop [array get ::p::${OID}::o_${prop}] + } else { + #ignore - array only represents properties that have been set. + #error "property $v is not set" + #!todo - unset corresponding items in $refvar if needed? + } + } + } + } + array set $refvar $plist +} + + +proc ::p::predator::object_read_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + + #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" + + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + if {[string length $IID]} { + #property + if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { + puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" + } + } else { + #method + error "property '$idx' not found" + } +} + + +proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd + + #!todo - ??? + + if {![llength [info commands ::p::${OID}::$idx]]} { + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set found 0 + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set found 1 + break + } + } + + if {$found} { + unset ::p::${OID}::o_$idx + } else { + puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" + } + } +} + + +proc ::p::predator::object_write_trace {OID _ID_ vref idx op} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd + #don't rely on variable name passed by trace. + set refvar ::p::${OID}::_ref::__OBJECT + #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" + + + if {![llength [info commands ::p::${OID}::$idx]]} { + #!todo - create new property in interface upon attempt to write to non-existant? + # - or should we require some different kind of object-reference for that? + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $MAP interfaces level0] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + #$IID is now topmost interface in default iStack which has this property + + if {[string length $IID]} { + #write to defined property + + ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] + } else { + #!todo - allow write of method body back to underlying object? + #attempted write to 'method' ..undo(?) + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "cannot write to method '$idx'" + #for now - disallow + } + } + +} + + + +proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} { + #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname + + set refindices [lassign [split [namespace tail $refname] +] prop] + #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop + #if there is no PropertyUnset command - we unset the underlying variable directly + + trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + + if {[catch { + + #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value + #i.e + if {[llength $refindices] && [string length $idx]} { + puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" + error "unexpected call to propref_trace_unset" + } + + + upvar #0 ::p::${OID}::_meta::map MAP + + set iflist [dict get $MAP interfaces level0] + #find topmost interface containing this $prop + set IID "" + foreach id [lreverse $iflist] { + if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { + set IID $id + break + } + } + if {![string length $IID]} { + error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" + } + + + + + + + if {[string length $idx]} { + #eval "$_alias ${unset_}$field $idx" + #what happens to $refindices??? + + + #!todo varspace + + if {![llength $refindices]} { + #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop}($idx) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx + } + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx + } else { + #assert - won't get here + error 1a + + } + + } else { + if {[llength $refindices]} { + #error 2a + #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + #review - what about list-type property? + #if {[array exists ::p::${OID}::o_${prop}]} ??? + unset ::p::${OID}::o_${prop}($refindices) + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices + } + + + + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices + + + } else { + #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + + #ref is not of form prop+x etc and no idx in the trace - this is a plain unset + if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { + unset ::p::${OID}::o_${prop} + } else { + ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" + } + #manually call refsync, passing it this refvar as an exclusion + ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} + + } + } + + + + + } errM]} { + #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" + set ruler [string repeat - 80] + puts stderr "\t$ruler" + puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + puts stderr "\t$ruler" + puts stderr $errM + puts stderr "\t$ruler" + + } else { + #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" + #puts stderr "*@*@*@*@ end propref_trace_unset - no error" + } + + trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] + + +} + + + + +proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} { + + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + + + if {[string length $triggeringRef]} { + set idx [lsearch -exact $refvars $triggeringRef] + if {$idx >= 0} { + set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] + } + } + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" + return + } + + + #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset + # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" + if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { + #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" + puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" + } + + + puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " + + + + upvar $vtraced SYNCVARIABLE + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + + + if {[array exists SYNCVARIABLE]} { + + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + + #set triggeringRefIdx $vidx + + if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { + set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] + } else { + set triggering_indices [list] + } + + + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + + + + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #check indices of triggering refvar match this refvars indices + + + if {$reftail eq [namespace tail $triggeringRef]} { + #!todo - add test + error "untested, possibly unused branch spuds2" + #puts "222222222222222222" + unset $refvar + } else { + + #error "untested - branch spuds2a" + + + } + + } else { + #!todo -add test + #reference is directly to property var + error "untested, possibly unused branch spuds3" + #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? + puts "\t33333333333333333333" + + if {[string length $triggeringRefIdx]} { + unset $refvar($triggeringRefIdx) + } + } + } + + } + + + + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + + + + +} + + +proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} { + + upvar $vtraced SYNCVARIABLE + + set refvars [::list] + #Do not use 'info exists' (avoid triggering read trace) - use info vars + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] + + + + #short_circuit breaks unset traces for array elements (why?) + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + return + } else { + puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" + } + + if {[catch { + + + + #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars + array set traces [::list] + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + if {$ops in {read write unset array}} { + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } + } + } + } + + + + + if {[array exists SYNCVARIABLE]} { + + #underlying variable is an array - we are presumably unsetting just an element + set vtracedIsArray 1 + } else { + #!? maybe the var was an array - but it's been unset? + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + #some things we don't want to repeat for each refvar in case there are lots of them.. + set triggeringRefIdx $vidx + + + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "--- unset branch refvar:$refvar" + + + + if {[llength $vidx]} { + #trace called with an index - must be an array + foreach refvar $refvars { + set reftail [namespace tail $refvar] + + if {[string match "${prop}+*" $reftail]} { + #!todo - add test + if {$vidx eq [lrange [split $reftail +] 1 end]} { + #unset if indices match + error "untested, possibly unused branch spuds1" + #puts "1111111111111111111111111" + unset $refvar + } + } else { + #test exists - #!todo - document which one + + #see if we succeeded in unsetting this element in the underlying variables + #(may have been blocked by a PropertyUnset body) + set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] + #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" + if {$element_exists} { + #do nothing it wasn't actually unset + } else { + #puts "JJJJJ unsetting ${refvar}($vidx)" + unset ${refvar}($vidx) + } + } + } + + + + + + } else { + + foreach refvar $refvars { + set reftail [namespace tail $refvar] + unset $refvar + + } + + } + + + + + #!todo - understand. + #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" + #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" + trace add variable $rv $ops $cmd + } + } + + } errM]} { + set ruler [string repeat * 80] + puts stderr "\t$ruler" + puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" + puts stderr "\t$ruler" + puts stderr $::errorInfo + puts stderr "\t$ruler" + + } + +} + +proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} { + error hmmmmm + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " + set refvars [::list] + + #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + #assert triggeringRef is in the list + if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { + error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" + } + set refposn [lsearch -exact $refvars $triggeringRef] + #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 + set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] + if {![llength $refvars]} { + #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" + return [list refs_updates [list]] + } + + #suppress the propref_trace_* traces on all refvars + array set traces [::list] + array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." + #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync + #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? + #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) + + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #all other traces are 'external' + lappend external_traces($rv) $tinfo + #trace remove variable $rv $ops $cmd + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + if {![info exists SYNCVARIABLE]} { + error "WARNING: REVIEW why does $vartraced not exist here?" + } + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set treat_vtraced_as_array 1 + } else { + set treat_vtraced_as_array 0 + } + + set refs_updated [list] + set refs_deleted [list] ;#unset due to index no longer being relevant + if {$treat_vtraced_as_array} { + foreach refvar $refvars { + #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + if {[llength $indices]} { + if {[llength $indices] == 1} { + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + #error "untested xxx-a" + set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] + lappend refs_updated $refvar + } else { + #test exists + #error "xxx-ok single index" + #updating a different part of the property - nothing to do + } + } else { + #nested index + if {[lindex $ref_indices 0] eq [lindex $indices 0]} { + if {[llength $ref_indices] == 1} { + #error "untested xxx-b1" + set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] + } else { + #assert llength $ref_indices > 1 + #NOTE - we cannot test index equivalence reliably/simply just by comparing indices + #compare by value + + if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { + #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" + if {[set $refvar] ne $possiblyNewVal} { + set $refvar $possiblyNewVal + } + } else { + #fail to retrieve underlying value corrsponding to these $indices + unset $refvar + } + } + } else { + #test exists + #error "untested xxx-ok deepindex" + #updating a different part of the property - nothing to do + } + } + } else { + error "untested xxx-c" + + } + + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + if {[llength $indices] == 1} { + set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] + } else { + lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] + } + lappend refs_updated $refvar + } else { + error "untested yyy" + set $refvar $SYNCVARIABLE + } + } + } + } else { + #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) + # + foreach refvar $refvars { + #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" + set refvar_tail [namespace tail $refvar] + if {[string match "${prop}+*" $refvar_tail]} { + #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y + set ref_indices [lrange [split $refvar_tail +] 1 end] + + if {[llength $indices]} { + #see if this update would affect this curried ref + #1st see if we can short-circuit our comparison based on numeric-indices + if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { + #both sets of indices are purely numeric (no end end-1 etc) + set rlen [llength $ref_indices] + set ilen [llength $indices] + set minlen [expr {min($rlen,$ilen)}] + set matched_firstfew_indices 1 ;#assume the best + for {set i 0} {$i < $minlen} {incr i} { + if {[lindex $ref_indices $i] ne [lindex $indices $i]} { + break ;# + } + } + if {!$matched_firstfew_indices} { + #update of this refvar not required + #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" + break ;#break to next refvar in the foreach loop + } + } + #failed to short-circuit + + #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set $refvar] ne $newval} { + set $refvar $newval + lappend refs_updated $refvar + } + + } else { + #we must be updating the entire variable - so this curried ref will either need to be updated or unset + set newval [lindex $SYNCVARIABLE $ref_indices] + if {[set ${refvar}] ne $newval} { + set ${refvar} $newval + lappend refs_updated $refvar + } + } + } else { + #refvar to update is plain e.g ::p::${OID}::_ref::${prop} + if {[llength $indices]} { + #error "untested zzz-a" + set newval [lindex $SYNCVARIABLE $indices] + if {[lindex [set $refvar] $indices] ne $newval} { + lset ${refvar} $indices $newval + lappend refs_updated $refvar + } + } else { + if {[set ${refvar}] ne $SYNCVARIABLE} { + set ${refvar} $SYNCVARIABLE + lappend refs_updated $refvar + } + } + + } + + } + } + #-------------------------------------------------------------------------------------------------------------------------- + + #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + } + foreach rv [array names external_traces] { + if {$rv ni $refs_deleted} { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + #trace add variable $rv $ops $cmd + } + } + } + + + return [list updated_refs $refs_updated] +} + +#purpose: update all relevant references when context variable changed directly +proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { + #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. + #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler + + upvar $vtraced SYNCVARIABLE + #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" + set t_info [trace vinfo $vtraced] + foreach t_spec $t_info { + set t_ops [lindex $t_spec 0] + if {$op in $t_ops} { + puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" + } + } + + #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- + #vtype = array | array-item | list | simple + + set refvars [::list] + + ############################ + #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! + #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) + #The alternative 'info vars' does not trigger traces + if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { + #puts " **> lappending '::p::REF::${OID}::$prop'" + lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + } + ############################ + + #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) + lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references + + + if {![llength $refvars]} { + #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" + return + } + + + #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" + + #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars + array set predator_traces [::list] + #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. + #ie for something like 'trace add variable someref {write read array} somefunc' + # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace + array set external_read_traces [::list] ;#pure read traces the library user may have added + array set external_readetc_traces [::list] ;#read + something else traces the library user may have added + foreach rv $refvars { + #puts "--refvar $rv" + foreach tinfo [trace info variable $rv] { + #puts "##trace $tinfo" + set ops {}; set cmd {} + lassign $tinfo ops cmd + #!warning - assumes traces with single operation per handler. + #write & unset traces on refvars need to be suppressed + #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. + #if {$ops in {read write unset array}} {} + + if {[string match "::p::predator::propref_trace_*" $cmd]} { + lappend predator_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" + } else { + #other traces + # puts "##trace $tinfo" + if {"read" in $ops} { + if {[llength $ops] == 1} { + #pure read - + lappend external_read_traces($rv) $tinfo + trace remove variable $rv $ops $cmd + } else { + #mixed operation trace - remove and reinstall without the 'read' + lappend external_readetc_traces($rv) $tinfo + set other_ops [lsearch -all -inline -not $ops "read"] + trace remove variable $rv $ops $cmd + #reinstall trace for non-read operations only + trace add variable $rv $other_ops $cmd + } + } + } + } + } + + + if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { + #either the underlying variable is an array + # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern + set vtracedIsArray 1 + } else { + set vtracedIsArray 0 + } + + #puts stderr "--------------------------------------------------\n\n" + + #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" + #puts stderr ">>> [trace info variable $vtraced]" + #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" + #puts "**write*********** refvars: $refvars" + + #!todo? unroll foreach into multiple foreaches within ifs? + #foreach refvar $refvars {} + + + #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" + if {[string length $vidx]} { + #indexable + if {$vtracedIsArray} { + + foreach refvar $refvars { + #puts stderr " - - a refvar $refvar vidx: $vidx" + set tail [namespace tail $refvar] + if {[string match "${prop}+*" $tail]} { + #refvar is curried + #only set if vidx matches curried index + #!todo -review + set idx [lrange [split $tail +] 1 end] + if {$idx eq $vidx} { + set newval [set SYNCVARIABLE($vidx)] + if {[set $refvar] ne $newval} { + set ${refvar} $newval + } + #puts stderr "=a.1=> updated $refvar" + } + } else { + #refvar is simple + set newval [set SYNCVARIABLE($vidx)] + if {![info exists ${refvar}($vidx)]} { + #new key for this array + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } else { + set oldval [set ${refvar}($vidx)] + if {$oldval ne $newval} { + #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " + array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] + } + } + #puts stderr "=a.2=> updated ${refvar} $vidx" + } + } + + + + } else { + + + foreach refvar $refvars { + upvar $refvar internal_property_reference + #puts stderr " - - b vidx: $vidx" + + #!? could be object not list?? + #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? + #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) + #There would still be an edge case of an initial write of a list of objects of length 1. + if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { + error "untested review!" + #the o_prop is object-shaped + #assumes object has a defaultmethod which accepts indices + set newval [[set $SYNCVARIABLE] {*}$vidx] + + } else { + set newval [lindex $SYNCVARIABLE {*}$vidx] + #if {[set $refvar] ne $newval} { + # set $refvar $newval + #} + if {$internal_property_reference ne $newval} { + set internal_property_reference $newval + } + + } + #puts stderr "=b=> updated $refvar" + } + + + } + + + + } else { + #no vidx + + if {$vtracedIsArray} { + + + foreach refvar $refvars { + set targetref_tail [namespace tail $refvar] + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + + #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" + if {$targetref_is_indexed} { + #curried array item ref of the form ${prop}+x or ${prop}+x+y etc + + #unindexed write on a property that is acting as an array.. + + #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. + + #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). + # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. + puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" + } else { + #How do we know what to write to array ref? + puts stderr "\tc.2 WARNING: unimplemented/unused?" + #error no_tests_for_branch + + #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation + #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate + array unset ${refvar} + array set ${refvar} [array get SYNCVARIABLE] + } + } + + + + } else { + foreach refvar $refvars { + #puts stderr "\t\t_________________[namespace current]" + set targetref_tail [namespace tail $refvar] + upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail + set targetref_is_indexed [string match "${prop}+*" $targetref_tail] + + if {$targetref_is_indexed} { + #puts "XXXXXXXXX vtraced:$vtraced" + #reference curried with index(es) + #we only set indexed refs if value has changed + # - this not required to be consistent with standard list-containing variable traces, + # as normally list elements can't be traced seperately anyway. + # + + + #only bother checking a ref if no setVia index + # i.e some operation on entire variable so need to test synchronisation for each element-ref + set targetref_indices [lrange [split $targetref_tail +] 1 end] + set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] + #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal + #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" + } + + + } else { + #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! + + #puts stderr "- d2 set" + #puts "refvar: [set $refvar]" + #puts "SYNCVARIABLE: $SYNCVARIABLE" + + #if {[set $refvar] ne $SYNCVARIABLE} { + # set $refvar $SYNCVARIABLE + #} + if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { + set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE + } + + } + } + + + } + + } + + + + + #reinstall the traces we stored at the beginning of this proc. + foreach rv [array names predator_traces] { + foreach tinfo $predator_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + foreach rv [array names external_traces] { + foreach tinfo $external_traces($rv) { + set ops {}; set cmd {} + lassign $tinfo ops cmd + + #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" + trace add variable $rv $ops $cmd + } + } + + + +} + +# end propvar_write_TraceHandler + + + + + + + + + + + + + + + + +# + +#returns 0 if method implementation not present for interface +proc ::p::predator::method_chainhead {iid method} { + #Interface proc + # examine the existing command-chain + set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex) + set cmdchain [list] + + set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}] + set maxversion 0 + #loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob. + foreach test [lsort -dictionary $candidates] { + set c [namespace tail $test] + if {[regexp $re $c _match version]} { + lappend cmdchain $c + if {$version > $maxversion} { + set maxversion $version + } + } + } + return $maxversion +} + + + + + +#this returns a script that upvars vars for all interfaces on the calling object - +# - must be called at runtime from a method +proc ::p::predator::upvar_all {_ID_} { + #::set OID [lindex $_ID_ 0 0] + ::set OID [::lindex [::dict get $_ID_ i this] 0 0] + ::set decl {} + #[set ::p::${OID}::_meta::map] + #[dict get [lindex [dict get $_ID_ i this] 0 1] map] + + ::upvar #0 ::p::${OID}::_meta::map MAP + #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" + #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] + + ::foreach ifid [dict get $MAP interfaces level0] { + if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} { + ::array unset nsvars + ::array set nsvars [::list] + ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { + ::set varspace [::dict get $vinfo varspace] + ::lappend nsvars($varspace) $vname + } + #nsvars now contains vars grouped by varspace. + + ::foreach varspace [::array names nsvars] { + if {$varspace eq ""} { + ::set ns ::p::${OID} + } else { + if {[::string match "::*" $varspace]} { + ::set ns $varspace + } else { + ::set ns ::p::${OID}::$varspace + } + } + + ::append decl "namespace upvar $ns " + ::foreach vname [::set nsvars($varspace)] { + ::append decl "$vname $vname " + } + ::append decl " ;\n" + } + ::array unset nsvars + } + } + ::return $decl +} + +#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator) +proc ::p::predator::runtime_vardecls {} { + set result "::eval \[::p::predator::upvar_all \$_ID_\]" + #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" + + #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" + #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" + #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" + return $result +} + + + + + + +#OBSOLETE!(?) - todo - move stuff out of here. +proc ::p::predator::compile_interface {IFID caller_ID_} { + upvar 0 ::p::${IFID}:: IFACE + + #namespace eval ::p::${IFID} { + # namespace ensemble create + #} + + #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables + + namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + #set varDecls {} + #if {[llength $o_variables]} { + # #puts "*********!!!! $vlist" + # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] " + # foreach vdef $o_variables { + # append varDecls "[lindex $vdef 0] [lindex $vdef 0] " + # } + # append varDecls \n + #} + + #runtime gathering of vars from other interfaces. + #append varDecls [runtime_vardecls] + + set varDecls [runtime_vardecls] + + + + #implement methods + + #!todo - avoid globs on iface array? maintain list of methods in another slot? + #foreach {n mname} [array get IFACE m-1,name,*] {} + + + #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. + + + + #implement property getters/setters/unsetters + #'setter' overrides + #pw short for propertywrite + foreach {n property} [array get IFACE pw,name,*] { + if {[string length $property]} { + #set property [lindex [split $n ,] end] + + #!todo - next_script + #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] + + set maxversion [::p::predator::method_chainhead $IFID (SET)$property] + set chainhead [expr {$maxversion + 1}] + set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 + + set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? + + set body $IFACE(pw,body,$property) + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" + } + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + set maxversion [::p::predator::method_chainhead $IFID $property] + set headid [expr {$maxversion + 1}] + + proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body + + interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid + + #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body + } + } + #'unset' overrides + + dict for {property handler_info} $o_propertyunset_handlers { + + set body [dict get $handler_info body] + set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array + + set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? + + + + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body" + + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + + + #implement + #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern "_dontcare_" + } + proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body + + + #chainhead pointer + interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid + } + + + + interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) + + #the usual case will have no destructor - so use info exists to check. + + if {[info exists ::p::${IFID}::_iface::o_destructor_body]} { + #!todo - chained destructors (support @next@). + #set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID] + set next NEXT + + set body [set ::p::${IFID}::_iface::o_destructor_body] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set body $varDecls\n[dict get $processed body] + #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body" + } + #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body] + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + proc ::p::${IFID}::___system___destructor _ID_ $body + } + + + if {[info exists o_unknown]} { + #use 'apply' somehow? + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + + #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] + } + + + return +} + + + + + + + +#'info args' - assuming arbitrary chain of 'interp aliases' +proc ::p::predator::command_info_args {cmd} { + if {[llength [set next [interp alias {} $cmd]]]} { + set curriedargs [lrange $next 1 end] + + if {[catch {set arglist [info args [lindex $next 0]]}]} { + set arglist [command_info_args [lindex $next 0]] + } + #trim curriedargs + return [lrange $arglist [llength $curriedargs] end] + } else { + info args $cmd + } +} + + +proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { + if {[llength $args]} { + tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args + } else { + if {[llength $nextArgs] > 1} { + set argVals [::list] + set i 0 + foreach arg [lrange $nextArgs 1 end] { + upvar 1 $arg $i + if {$arg eq "args"} { + #need to check if 'args' is actually available in caller + if {[info exists $i]} { + set argVals [concat $argVals [set $i]] + } + } else { + lappend argVals [set $i] + } + } + tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals + } else { + tailcall ::p::${IFID}::_iface::$mname $_ID_ + } + } +} + +#---------------------------------------------------------------------------------------------- +proc ::p::predator::next_script {IFID method caller caller_ID_} { + + if {$caller eq "(CONSTRUCTOR).1"} { + return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}] + } elseif {$caller eq "$method.1"} { + #delegate to next interface lower down the stack which has a member named $method + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } elseif {[string match "(GET)*.2" $caller]} { + # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. + + #jmn + set prop [string trimright $caller 1234567890] + set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing . + + if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} { + #return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}] + return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] + } else { + #we can actually have a property read without a property or a method of that name - but it could also match the name of a method. + # (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something) + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } + } elseif {[string match "(SET)*.2" $caller]} { + return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] + } else { + #this branch will also handle (SET)*.x and (GET)*.x where x >2 + + #puts stdout "............next_script IFID:$IFID method:$method caller:$caller" + set callerid [string range $caller [string length "$method."] end] + set nextid [expr {$callerid - 1}] + + if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} { + #not a proc directly on this interface - presumably an alias made by something like linkcopy_interface. + #puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid" + set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid] + } + + return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] + } +} + +proc ::p::predator::do_next_if {_ID_ IFID method args} { + #puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' (((" + + #set invocants [dict get $_ID_ i] + #set this_invocantdata [lindex [dict get $invocants this] 0] + #lassign $this_invocantdata OID this_info + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set interfaces [dict get $MAP interfaces level0] + set patterninterfaces [dict get $MAP interfaces level1] + + set L0_posn [lsearch $interfaces $IFID] + if {$L0_posn == -1} { + error "(::p::predator::do_next_if) called with interface not present at level0 for this object" + } elseif {$L0_posn > 0} { + #set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack + set lower_interfaces [lrange $interfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {[string match "(GET)*" $method]} { + #do not test o_properties here! We need to call even if there is no underlying property on this interface + #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) + # relevant test: higher_order_propertyread_chaining + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + } elseif {[string match "(SET)*" $method]} { + #must be called even if there is no matching $method in o_properties + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + } elseif {[string match "(UNSET)*" $method]} { + #review untested + #error "do_next_if (UNSET) untested" + #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'" + return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + + } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} { + if {[llength $args]} { + #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args" + + #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] + #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args + + #!todo - handle case where llength $args is less than number of args for subinterface command + #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set) + + #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature) + set head [interp alias {} ::p::${if_sub}::_iface::$method] + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc + set argx [list] + foreach a $nextArgs { + lappend argx "\$a" + } + + #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared + + if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} { + tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args + } else { + #todo - upvars required for tail end of arglist + tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args + } + + } else { + #auto-set: upvar vars from calling scope + #!todo - robustify? alias not necessarily matching command name.. + set head [interp alias {} ::p::${if_sub}::_iface::$method] + + + set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc + if {[llength $nextArgs] > 1} { + set argVals [::list] + set i 0 + foreach arg [lrange $nextArgs 1 end] { + upvar 1 $arg $i + if {$arg eq "args"} { + #need to check if 'args' is actually available in caller + if {[info exists $i]} { + set argVals [concat $argVals [set $i]] + } + } else { + lappend argVals [set $i] + } + } + #return [$head $_ID_ {*}$argVals] + tailcall $head $_ID_ {*}$argVals + } else { + #return [$head $_ID_] + tailcall $head $_ID_ + } + } + } elseif {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + #return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args] + xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } +} + + +#only really makes sense for (CONSTRUCTOR) calls. +#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class. +proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { + #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" + + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + #set OID [lindex [dict get $invocants this] 0 0] + #upvar #0 ::p::${OID}::_meta::map map + #lassign [lindex $map 0] OID alias itemCmd cmd + + + set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] + upvar #0 ::p::${caller_OID}::_meta::map callermap + + #set interfaces [lindex $map 1 0] + set patterninterfaces [dict get $callermap interfaces level1] + + set L0_posn [lsearch $patterninterfaces $IFID] + if {$L0_posn == -1} { + error "do_next_pattern_if called with interface not present at level1 for this object" + } elseif {$L0_posn > 0} { + + + set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] + + foreach if_sub [lreverse $lower_interfaces] { + if {$method eq "(CONSTRUCTOR)"} { + #chained constructors will only get args if the @next@ caller explicitly provided them. + #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" + tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args + } + } + #no interfaces in the iStack contained a matching method. + return + } else { + #no further interfaces in this iStack + return + } +} + + + + + +#------------------------------------------------------------------------------------------------ + + + + + +#------------------------------------------------------------------------------------- +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### +####################################################### + + +#!todo - can we just call new_object somehow to create this? + + #until we have a version of Tcl that doesn't have 'creative writing' scope issues - + # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. + # (see http://mini.net/tcl/1030 'Dangers of creative writing') +namespace eval ::p::-1 { + #namespace ensemble create + + namespace eval _ref {} + namespace eval _meta {} + + namespace eval _iface { + variable o_usedby + variable o_open + variable o_constructor + variable o_variables + variable o_properties + variable o_methods + variable o_definition + variable o_varspace + variable o_varspaces + + array set o_usedby [list i0 1] ;#!todo - review + #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? + + set o_open 1 + set o_constructor [list] + set o_variables [list] + set o_properties [dict create] + set o_methods [dict create] + array set o_definition [list] + set o_varspace "" + set o_varspaces [list] + } +} + + +# + +#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}] +interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}] + + +upvar #0 ::p::-1::_iface::o_definition def + + +#! concatenate -> compose ?? +dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}} +proc ::p::-1::Concatenate {_ID_ target args} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {![string match "::*" $target]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set target ::$target + } else { + set target ${ns}::$target + } + } + #add > character if not already present + set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] + set _target [string map {::> ::} $target] + + set ns [namespace qualifiers $target] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } + + if {![llength [info commands $target]]} { + #degenerate case - target does not exist + #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone' + #review - should be 'Copy' so it has object state from namespaces and variables? + return [::p::-1::Clone $_ID_ $target {*}$args] + + #set TARGETMAP [::p::predator::new_object $target] + #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd + + } else { + #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] + set TARGETMAP [$target --] + + lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd + + #Merge lastmodified(?) level0 and level1 interfaces. + + } + + return $target +} + + + +#Object's Base-Interface proc with itself as curried invocant. +#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant +#namespace eval ::p::-1 {namespace export Create} +dict set ::p::-1::_iface::o_methods Define {arglist definitions} +#define objects in one step +proc ::p::-1::Define {_ID_ definitions} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias default_method cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + + #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack + #set IFID0 [lindex $interfaces 0] + #set IFID1 [lindex $patterns 0] ;#1st pattern + + #set IFID_TOP [lindex $interfaces end] + set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] + + #set ns ::p::${OID} + + #set script [string map [list %definitions% $definitions] { + # if {[lindex [namespace path] 0] ne "::p::-1"} { + # namespace path [list ::p::-1 {*}[namespace path]] + # } + # %definitions% + # namespace path [lrange [namespace path] 1 end] + # + #}] + + set script [string map [list %id% $_ID_ %definitions% $definitions] { + set ::p::-1::temp_unknown [namespace unknown] + + namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] + + + #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] + + + %definitions% + + + namespace unknown ${::p::-1::temp_unknown} + return + }] + + + + #uplevel 1 $script ;#this would run the script in the global namespace + #run script in the namespace of the open interface, this allows creating of private helper procs + #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack + #namespace inscope ::p::${OID} $script + namespace eval ::p::${OID} $script + #return $cmd +} + + +proc ::p::predator::redirect {func args} { + + #todo - review tailcall - tests? + if {![llength [info commands ::p::-1::$func]]} { + #error "invalid command name \"$func\"" + tailcall uplevel 1 [list ::unknown $func {*}$args] + } else { + tailcall uplevel 1 [list ::p::-1::$func {*}$args] + } +} + + +#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review. +dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}} +proc ::p::-1::Construct {_ID_ argpairs body args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace + + set ARGSETTER {} + foreach {argname argval} $argpairs { + append ARGSETTER "set $argname $argval\n" + } + #$_self (VIOLATE) $ARGSETTER$body + + set body $ARGSETTER\n$body + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + # puts stderr "\t runtime_vardecls in Construct $varDecls" + } + + set next "\[error {next not implemented}\]" + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + #namespace eval ::p::${iid_top} $body + + #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] + #does this handle Varspace before constructor? + return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] +} + + + + + +#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects +namespace eval ::p::3 {} +proc ::p::3::_create {child {OID "-2"}} { + #puts stderr "::p::3::_create $child $OID" + set _child [string map {::> ::} $child] + if {$OID eq "-2"} { + #set childmapdata [::p::internals::new_object $child] + #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] + set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } else { + set child_ID $OID + #set _childmap [::p::internals::new_object $child "" $child_ID] + ::p::internals::new_object $child "" $child_ID + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + } + + #-------------- + + set oldinterfaces [dict get $CHILDMAP interfaces] + dict set oldinterfaces level0 [list 2] + set modifiedinterfaces $oldinterfaces + dict set CHILDMAP interfaces $modifiedinterfaces + + #-------------- + + + + + #puts stderr ">>>> creating alias for ::p::$child_ID" + #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" + + #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! + #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] + #puts stderr ">>>[interp alias {} ::p::$child_ID]" + + + + #--------------- + namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties + foreach method [dict keys $o_methods] { + #todo - change from interp alias to context proc + interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method + } + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop + + } + ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] + #--------------- + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + return $child +} + +#configure -prop1 val1 -prop2 val2 ... +dict set ::p::-1::_iface::o_methods Configure {arglist args} +proc ::p::-1::Configure {_ID_ args} { + + #!todo - add tests. + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd this + + if {![expr {([llength $args] % 2) == 0}]} { + error "expected even number of Configure args e.g '-property1 value1 -property2 value2'" + } + + #Do a separate loop to check all the arguments before we run the property setting loop + set properties_to_configure [list] + foreach {argprop val} $args { + if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} { + error "expected Configure args in the form: '-property1 value1 -property2 value2'" + } + lappend properties_to_configure [string range $argprop 1 end] + } + + #gather all valid property names for all level0 interfaces in the relevant interface stack + set valid_property_names [list] + set iflist [dict get $MAP interfaces level0] + foreach id [lreverse $iflist] { + set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]] + foreach if_prop $interface_property_names { + if {$if_prop ni $valid_property_names} { + lappend valid_property_names $if_prop + } + } + } + + foreach argprop $properties_to_configure { + if {$argprop ni $valid_property_names} { + error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names" + } + } + + set top_IID [lindex $iflist end] + #args ok - go ahead and set all properties + foreach {prop val} $args { + set property [string range $prop 1 end] + #------------ + #don't use property ref unnecessarily - leaves property refs hanging around which traces need to update + #ie don't do this here: set [$this . $property .] $val + #------------- + ::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val] + } + return +} + + + + + + +dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid} +proc ::p::-1::AddPatternInterface {_ID_ iid} { + #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces + + + + #it is theoretically possible to have the same interface present multiple times in an iStack. + # #!todo -review why/whether this is useful. should we disallow it and treat as an error? + + lappend existing_ifaces $iid + #lset map {1 1} $existing_ifaces + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + + #lset invocant {1 1} $existing_ifaces + +} + + +#!todo - update usedby ?? +dict set ::p::-1::_iface::o_methods AddInterface {arglist iid} +proc ::p::-1::AddInterface {_ID_ iid} { + #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + + lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. + set this_invocant [lindex $list_of_invocants_for_role_this 0] + + lassign $this_invocant OID _etc + + upvar #0 ::p::${OID}::_meta::map MAP + set existing_ifaces [dict get $MAP interfaces level0] + + lappend existing_ifaces $iid + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 $existing_ifaces + dict set MAP interfaces $extracted_sub_dict + return [dict get $extracted_sub_dict level0] +} + + + +# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module. +# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist +# and 'CreateOverlay' for the case where the target/child object already exists. +# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence, +# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object. +# 'CreateNew' will raise an error if the target already exists +# 'CreateOverlay' will raise an error if the target object does not exist. +# 'Create' will work in either case. Creating the target if necessary. + + +#simple form: +# >somepattern .. Create >child +#simple form with arguments to the constructor: +# >somepattern .. Create >child arg1 arg2 etc +#complex form - specify more info about the target (dict keyed on childobject name): +# >somepattern .. Create {>child {-id 1}} +#or +# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] +#complex form - with arguments to the contructor: +# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc +dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}} +proc ::p::-1::Create {_ID_ target_spec args} { + #$args are passed to constructor + if {[llength $target_spec] ==1} { + set child $target_spec + set targets [list $child {}] + } else { + set targets $target_spec + } + + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) + + foreach {child target_spec_dict} $targets { + #puts ">>>::p::-1::Create $_ID_ $child $args <<<" + + + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + + + + #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID" + + #child should already be fully ns qualified (?) + #ensure it is has a pattern-object marker > + #puts stderr ".... $child (nsqual: [namespace qualifiers $child])" + + + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces + set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces + #puts "parent: $OID -> child:$child Patterns $patterns" + + #todo - change to dict of interface stacks + set IFID0 [lindex $interfaces 0] + set IFID1 [lindex $patterns 0] ;#1st pattern + + #upvar ::p::${OID}:: INFO + + if {![string match {::*} $child]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set child ::$child + } else { + set child ${ns}::$child + } + } + + + #add > character if not already present + set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >] + set _child [string map {::> ::} $child] + + set ns [namespace qualifiers $child] + if {$ns eq ""} { + set ns "::" + } else { + namespace eval $ns {} + } + + + #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls. + set new_interfaces [list] + + if {![llength $patterns]} { + ##puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $cmd when creating $child" + #lappend patterns [::p::internals::new_interface $OID] + + #lset invocant {1 1} $patterns + ##update our command because we changed the interface list. + #set IFID1 [lindex $patterns 0] + + #set patterns [list [::p::internals::new_interface $OID]] + + #set patterns [list [::p::internals::new_interface]] + + #set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id + #set patterns [list [set iid [incr ::p::ID]]] + set patterns [list [set iid [::p::get_new_object_id]]] + + #--------- + #set iface [::p::>interface .. Create ::p::ifaces::>$iid] + #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid + + #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation + lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid] + + #--------- + + #puts "??> p::>interface .. Create ::p::ifaces::>$iid" + #puts "??> [::p::ifaces::>$iid --]" + #set [$iface . UsedBy .] + } + set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] + + #if {![llength [info commands $child]]} {} + + if {[namespace which $child] eq ""} { + #normal case - target/child does not exist + set is_new_object 1 + + if {[dict exists $target_spec_dict -id]} { + set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]] + } else { + set childmapdata [::p::internals::new_object $child] + } + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + + + + #child initially uses parent's level1 interface as it's level0 interface + # child has no level1 interface until PatternMethods or PatternProperties are added + # (or applied via clone; or via create with a parent with level2 interface) + #set child_IFID $IFID1 + + #lset CHILDMAP {1 0} [list $IFID1] + #lset CHILDMAP {1 0} $patterns + + set extracted_sub_dict [dict get $CHILDMAP interfaces] + dict set extracted_sub_dict level0 $patterns + dict set CHILDMAP interfaces $extracted_sub_dict + + #why write back when upvared??? + #review + set ::p::${child_ID}::_meta::map $CHILDMAP + + #::p::predator::remap $CHILDMAP + + #interp alias {} $child {} ::p::internals::predator $CHILDMAP + + #set child_IFID $IFID1 + + #upvar ::p::${child_ID}:: child_INFO + + #!todo review + #set n ::p::${child_ID} + #if {![info exists ${n}::-->PATTERN_ANCHOR]} { + # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" + # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack + # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" + # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] + #} + + set ifaces_added $patterns + + } else { + #overlay/mixin case - target/child already exists + set is_new_object 0 + + #set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1] + set childmapdata [$child --] + + + #puts stderr " *** $cmd .. Create -> target $child already exists!!!" + #puts " **** CHILDMAP: $CHILDMAP" + #puts " ****" + + #puts stderr " ---> Properties: [$child .. Properties . names]" + #puts stderr " ---> Methods: [$child .. Properties . names]" + + lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd + upvar #0 ::p::${child_ID}::_meta::map CHILDMAP + + #set child_IFID [lindex $CHILDMAP 1 0 end] + #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} { + # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] + # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP + #} + ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces + #::p::merge_interface $IFID1 $child_IFID + + + set existing_interfaces [dict get $CHILDMAP interfaces level0] + set ifaces_added [list] + foreach p $patterns { + if {$p ni $existing_interfaces} { + lappend ifaces_added $p + } + } + + if {[llength $ifaces_added]} { + #lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added] + set extracted_sub_dict [dict get $CHILDMAP interfaces] + dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added] + dict set CHILDMAP interfaces $extracted_sub_dict + #set ::p::${child_ID}::_meta::map $CHILDMAP ;#why? + #::p::predator::remap $CHILDMAP + } + } + + #do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty + if {$parent_patterndefaultmethod ne ""} { + set child_defaultmethod $parent_patterndefaultmethod + set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata] + lset CHILD_INVOCANTDATA 2 $child_defaultmethod + dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA + #update the child's _ID_ + interp alias {} $child_alias {} ;#first we must delete it + interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}] + + #! object_command was initially created as the renamed alias - so we have to do it again + rename $child_alias $child + trace add command $child rename [list $child .. Rename] + } + #!todo - review - dont we already have interp alias entries for every method/prop? + #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" + + + + + + set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call. + + + + #------------------------------------------------------------------------------------ + #create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail. + # - All variables under the namespace - not just those declared as Variables or Properties + # - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces. + # - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write. + + #NOTE - do not use the objectID as the sole identifier for the snapshot namespace. + # - there may be multiple active snapshots for a single object if it overlays itself during a constructor, + # and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call. + # - we will use an ever-increasing snapshotid to form part of ns_snap + set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create. + + #!todo - this should look at child namespaces (recursively?) + #!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces. + # (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace) + + namespace eval $ns_snap {} + foreach vname [info vars ::p::${child_ID}::*] { + set shortname [namespace tail $vname] + if {[array exists $vname]} { + array set ${ns_snap}::${shortname} [array get $vname] + } elseif {[info exists $vname]} { + set ${ns_snap}::${shortname} [set $vname] + } else { + #variable exists without value (e.g created by 'variable' command) + namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist' + } + } + #------------------------------------------------------------------------------------ + + + + + + + + + + #puts "====>>> ifaces_added $ifaces_added" + set idx 0 + set idx_count [llength $ifaces_added] + set highest_constructor_IFID "" + foreach IFID $ifaces_added { + incr idx + #puts "--> adding iface $IFID " + namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces + + if {[llength $o_varspaces]} { + foreach vs $o_varspaces { + #ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work. + if {[string match "::*" $vs]} { + namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all. + } else { + namespace eval ::p::${child_ID}::$vs {} + } + } + } + + if {$IFID != 2} { + #>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list. + if {![info exists o_usedby(i$child_ID)]} { + set o_usedby(i$child_ID) $child_alias + } + + #compile and close the interface only if it is shared + if {$o_open} { + ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_ + set o_open 0 + } + } + + + + package require struct::set + + set propcmds [list] + foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] { + set cmd [namespace tail $cmd] + #may contain multiple results for same prop e.g (GET)x.3 + set cmd [string trimright $cmd 0123456789] + set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals + lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. + } + set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. + #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. + foreach property $propcmds { + #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n" + interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces + interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property + } + + set propcmds [list] + foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] { + set cmd [namespace tail $cmd] + #may contain multiple results for same prop e.g (GET)x.3 + set cmd [string trimright $cmd 0123456789] + set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals + lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. + } + set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. + #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. + foreach property $propcmds { + interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces + } + + + foreach method [dict keys $o_methods] { + set arglist [dict get $o_methods $method arglist] + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + + #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method + + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #proc calls the method in the interface - which is an interp alias to the head of the implementation chain + + + proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IFID}::_iface::$method \$_ID_ $argvals + }] + + #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] { + # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ + #}] + + + } + + #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] + + #implement property even if interface already compiled because we need to create defaults for each new child obj. + # also need to add alias on base interface + #make sure we are only implementing properties from the current CREATOR + dict for {prop pdef} $o_properties { + set varspace [dict get $pdef varspace] + if {![string length $varspace]} { + set ns ::p::${child_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${child_ID}::$varspace + } + } + if {[dict exists $pdef default]} { + if {![info exists ${ns}::o_$prop]} { + #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) + set ${ns}::o_$prop [dict get $pdef default] + } + } + #! May be replaced by a method with the same name + if {$prop ni [dict keys $o_methods]} { + interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop + } + interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop + interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop + } + + + + #variables + #foreach vdef $o_variables { + # if {[llength $vdef] == 2} { + # #there is a default value defined. + # lassign $vdef v default + # if {![info exists ::p::${child_ID}::$v]} { + # set ::p::${child_ID}::$v $default + # } + # } + #} + dict for {vname vdef} $o_variables { + if {[dict exists $vdef default]} { + #there is a default value defined. + set varspace [dict get $vdef varspace] + if {$varspace eq ""} { + set ns ::p::${child_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${child_ID}::$varspace + } + } + set ${ns}::$vname [dict get $vdef default] + } + } + + + #!todo - review. Write tests for cases of multiple constructors! + + #We don't want to the run constructor for each added interface with the same set of args! + #run for last one - rely on constructor authors to use @next@ properly? + if {[llength [set ::p::${IFID}::_iface::o_constructor]]} { + set highest_constructor_IFID $IFID + } + + if {$idx == $idx_count} { + #we are processing the last interface that was added - now run the latest constructor found + if {$highest_constructor_IFID ne ""} { + #at least one interface has a constructor + if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} { + #puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP" + if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} { + set constructor_failure 1 + set constructor_errorInfo $::errorInfo ;#cache it immediately. + break + } + } + } + } + + if {[info exists o_unknown]} { + interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown + interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + + + #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown + #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] + #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown] + } + } + + if {$constructor_failure} { + if {$is_new_object} { + #is Destroy enough to ensure that no new interfaces or objects were left dangling? + $child .. Destroy + } else { + #object needs to be returned to a sensible state.. + #attempt to rollback all interface additions and object state changes! + puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n" + #remove variables from the object's namespace - which don't exist in the snapshot. + set snap_vars [info vars ${ns_snap}::*] + puts "ns_snap '$ns_snap' vars'${snap_vars}'" + foreach vname [info vars ::p::${child_ID}::*] { + set shortname [namespace tail $vname] + if {"${ns_snap}::$shortname" ni "$snap_vars"} { + #puts "--- >>>>> unsetting $shortname " + unset -nocomplain $vname + } + } + + #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces) + #values of vars may also have Changed + #todo - consider traces? what is the correct behaviour? + # - some application traces may have fired before the constructor error occurred. + # Should the rollback now also trigger traces? + #probably yes. + + #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value + foreach vname $snap_vars { + #puts stdout "@@@@@@@@@@@ restoring $vname" + #flush stdout + + + set shortname [namespace tail $vname] + set target ::p::${child_ID}::$shortname + if {$target in [info vars ::p::${child_ID}::*]} { + set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only' + } else { + set present 0 + } + + if {[array exists $vname]} { + #restore 'array' variable + if {!$present} { + array set $target [array get $vname] + } else { + if {[array exists $target]} { + #unset superfluous elements + foreach key [array names $target] { + if {$key ni [array names $vname]} { + array unset $target $key + } + } + #.. and write only elements that have changed. + foreach key [array names $vname] { + if {[set ${target}($key)] ne [set ${vname}($key)]} { + set ${target}($key) [set ${vname}($key)] + } + } + } else { + #target has been changed to a simple variable - unset it and recreate the array. + unset $target + array set $target [array get $vname] + } + } + } elseif {[info exists $vname]} { + #restore 'simple' variable + if {!$present} { + set $target [set $vname] + } else { + if {[array exists $target]} { + #target has been changed to array - unset it and recreate the simple variable. + unset $target + set $target [set $vname] + } else { + if {[set $target] ne [set $vname]} { + set $target [set $vname] + } + } + } + } else { + #restore 'declared' variable + if {[array exists $target] || [info exists $target]} { + unset -nocomplain $target + } + namespace eval ::p::${child_ID} [list variable $shortname] + } + } + } + namespace delete $ns_snap + return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error + } + namespace delete $ns_snap + + } + + + + return $child +} + +dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} +#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied* +# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*) +# Also: Any 'open' interfaces on the parent become closed on clone! +proc ::p::-1::Clone {_ID_ clone args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set invocants [dict get $_ID_ i] + lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd + + set _cmd [string map {::> ::} $cmd] + set tail [namespace tail $_cmd] + + + #obsolete? + ##set IFID0 [lindex $map 1 0 end] + #set IFID0 [lindex [dict get $MAP interfaces level0] end] + ##set IFID1 [lindex $map 1 1 end] + #set IFID1 [lindex [dict get $MAP interfaces level1] end] + + + if {![string match "::*" $clone]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set clone ::$clone + } else { + set clone ${ns}::$clone + } + } + + + set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] + set _clone [string map {::> ::} $clone] + + + set cTail [namespace tail $_clone] + + set ns [namespace qualifiers $clone] + if {$ns eq ""} { + set ns "::" + } + + namespace eval $ns {} + + + #if {![llength [info commands $clone]]} {} + if {[namespace which $clone] eq ""} { + set clonemapdata [::p::internals::new_object $clone] + } else { + #overlay/mixin case - target/clone already exists + #set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1] + set clonemapdata [$clone --] + } + set clone_ID [lindex [dict get $clonemapdata invocantdata] 0] + + upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP + + + #copy patterndata element of MAP straight across + dict set CLONEMAP patterndata [dict get $MAP patterndata] + set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata] + lset CLONE_INVOCANTDATA 2 $parent_defaultmethod + dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA + lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone + + #update the clone's _ID_ + interp alias {} $clone_alias {} ;#first we must delete it + interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}] + + #! object_command was initially created as the renamed alias - so we have to do it again + rename $clone_alias $clone + trace add command $clone rename [list $clone .. Rename] + + + + + #obsolete? + #upvar ::p::${clone_ID}:: clone_INFO + #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. + #upvar ::p::${OID}:: INFO + + + array set clone_INFO [array get INFO] + + array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' + + + #!review! + #if {![catch {set itemCmd $IFACE(m-1,name,item)}]} { + #puts "***************" + #puts "clone" + #parray IFINFO + #puts "***************" + #} + + #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern + + + #clone's interface maps must be a superset of original's + foreach lev {0 1} { + #set parent_ifaces [lindex $map 1 $lev] + set parent_ifaces [dict get $MAP interfaces level$lev] + + #set existing_ifaces [lindex $CLONEMAP 1 $lev] + set existing_ifaces [dict get $CLONEMAP interfaces level$lev] + + set added_ifaces_$lev [list] + foreach ifid $parent_ifaces { + if {$ifid ni $existing_ifaces} { + + #interface must not remain extensible after cloning. + if {[set ::p::${ifid}::_iface::o_open]} { + ::p::predator::compile_interface $ifid $_ID_ + set ::p::${ifid}::_iface::o_open 0 + } + + + + lappend added_ifaces_$lev $ifid + #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. + set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone + } + } + set extracted_sub_dict [dict get $CLONEMAP interfaces] + dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]] + dict set CLONEMAP interfaces $extracted_sub_dict + #lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]] + } + + #interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE) + + + #foreach *added* level0 interface.. + foreach ifid $added_ifaces_0 { + namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown + + + dict for {prop pdef} $o_properties { + #lassign $pdef prop default + if {[dict exists $pdef default]} { + set varspace [dict get $pdef varspace] + if {$varspace eq ""} { + set ns ::p::${clone_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${clone_ID}::$varspace + } + } + + if {![info exists ${ns}::o_$prop]} { + #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) + set ${ns}::o_$prop [dict get $pdef default] + } + } + + #! May be replaced by method of same name + if {[namespace which ::p::${clone_ID}::$prop] eq ""} { + interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop + } + interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop + interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop + } + + #variables + dict for {vname vdef} $o_variables { + if {[dict exists $vdef default]} { + set varspace [dict get $vdef varspace] + if {$varspace eq ""} { + set ns ::p::${clone_ID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${clone_ID}::$varspace + } + } + if {![info exists ${ns}::$vname]} { + set ::p::${clone_ID}::$vname [dict get $vdef default] + } + } + } + + + #update the clone object's base interface to reflect the new methods. + #upvar 0 ::p::${ifid}:: IFACE + #set methods [list] + #foreach {key mname} [array get IFACE m-1,name,*] { + # set method [lindex [split $key ,] end] + # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP + # lappend methods $method + #} + #namespace eval ::p::${clone_ID} [list namespace export {*}$methods] + + + foreach method [dict keys $o_methods] { + + set arglist [dict get $o_methods $method arglist] + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method + + + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #proc calls the method in the interface - which is an interp alias to the head of the implementation chain + proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${ifid}::_iface::$method \$_ID_ $argvals + }] + + } + #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods] + + + if {[info exists o_unknown]} { + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown + interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown + + #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown] + #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown] + + } + + + #2021 + #Consider >parent with constructor that sets height + #.eg >parent .. Constructor height { + # set o_height $height + #} + #>parent .. Create >child 5 + # - >child has height 5 + # now when we peform a clone operation - it is the >parent's constructor that will run. + # A clone will get default property and var values - but not other variable values unless the constructor sets them. + #>child .. Clone >fakesibling 6 + # - >sibling has height 6 + # Consider if >child had it's own constructor created with .. Construct prior to the clone operation. + # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead. + # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining... + # when we now do >sibling .. Create >grandchild + # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild + # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.) + # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild + #(though other arguments can be manually passed) + # #!review - does this make sense? What if we add + # + #constructor for each interface called after properties initialised. + #run each interface's constructor against child object, using the args passed into this clone method. + if {[llength [set constructordef [set o_constructor]]]} { + #error + puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID" + ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args + + } + + } + + + return $clone + +} + + + +interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?) +dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}} +proc ::p::-1::Constructor {_ID_ arglist body} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #set iid_top [::p::get_new_object_id] + + #the >interface constructor takes a list of IDs for o_usedby + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + + #::p::predator::remap $invocant + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] + set headid [expr {$maxversion + 1}] + set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 + + set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] + + #set varspaces [::pattern::varspace_list] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] + set body $varDecls\n[dict get $processed body] + #puts stderr "\t runtime_vardecls in Constructor $varDecls" + } + + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #puts stderr ---- + #puts stderr $body + #puts stderr ---- + + proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body + interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid + + + + set o_constructor [list $arglist $body] + set o_open 1 + + return +} + + + +dict set ::p::-1::_iface::o_methods UsedBy {arglist {}} +proc ::p::-1::UsedBy {_ID_} { + return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby] +} + + +dict set ::p::-1::_iface::o_methods Ready {arglist {}} +proc ::p::-1::Ready {_ID_} { + return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}] +} + + + +dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}} + +#'force' 1 indicates object command & variable will also be removed. +#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var. +#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4) +# +proc ::p::-1::Destroy {_ID_ {force 1}} { + #puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]" + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + + if {$OID eq "null"} { + puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" + return + } + + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout + + #explicit Destroy - remove traces + #puts ">>TRACES: [trace info variable $cmd]" + #foreach tinfo [trace info variable $cmd] { + # trace remove variable $cmd {*}$tinfo + #} + #foreach tinfo [trace info command $cmd] { + # trace remove command $cmd {*}$tinfo + #} + + + set _cmd [string map {::> ::} $cmd] + + #set ifaces [lindex $map 1] + set iface_stacks [dict get $MAP interfaces level0] + #set patterns [lindex $map 2] + set pattern_stacks [dict get $MAP interfaces level1] + + + + set ifaces $iface_stacks + + + set patterns $pattern_stacks + + + #set i 0 + #foreach iflist $ifaces { + # set IFID$i [lindex $iflist 0] + # incr i + #} + + + set IFTOP [lindex $ifaces end] + + set DESTRUCTOR ::p::${IFTOP}::___system___destructor + #may be a proc, or may be an alias + if {[namespace which $DESTRUCTOR] ne ""} { + set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] + + if {[catch {$DESTRUCTOR $temp_ID_} prob]} { + #!todo - ensure correct calling order of interfaces referencing the destructor proc + + + #!todo - emit destructor errors somewhere - logger? + #puts stderr "underlying proc already removed??? ---> $prob" + #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" + #puts stderr $::errorInfo + #puts stderr "---------------------" + } + } + + + #remove ourself from each interfaces list of referencers + #puts stderr "--- $ifaces" + + foreach var {ifaces patterns} { + + foreach i [set $var] { + + if {[string length $i]} { + if {$i == 2} { + #skip the >ifinfo interface which doesn't maintain a usedby list anyway. + continue + } + + if {[catch { + + upvar #0 ::p::${i}::_iface::o_usedby usedby + + array unset usedby i$OID + + + #puts "\n***>>***" + #puts "IFACE: $i usedby: $usedby" + #puts "***>>***\n" + + #remove interface if no more referencers + if {![array size usedby]} { + #puts " **************** DESTROYING unused interface $i *****" + #catch {namespace delete ::p::$i} + + #we happen to know where 'interface' object commands are kept: + + ::p::ifaces::>$i .. Destroy + + } + + } errMsg]} { + #warning + puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" + } + } + + } + + } + + set ns ::p::${OID} + #puts "-- destroying objects below namespace:'$ns'" + ::p::internals::DestroyObjectsBelowNamespace $ns + #puts "--.destroyed objects below '$ns'" + + + #set ns ::p::${OID}::_sub + #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace + #( ::p::OBJECT::$OID ) + #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" + #::p::internals::DestroyObjectsBelowNamespace $ns + + #same for _meta objects (e.g Methods,Properties collections) + #set ns ::p::${OID}::_meta + #::p::internals::DestroyObjectsBelowNamespace $ns + + + + #foreach obj [info commands ${ns}::>*] { + # #Assume it's one of ours, and ask it to die. + # catch {::p::meta::Destroy $obj} + # #catch {$cmd .. Destroy} + #} + #just in case the user created subnamespaces.. kill objects there too. + #foreach sub [namespace children $ns] { + # ::p::internals::DestroyObjectsBelowNamespace $sub + #} + + + #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value! + #use info commands ::p::${OID}::_ref::* to find all references - including variables never set + #remove variable traces on REF vars + #foreach rv [info vars ::p::${OID}::_ref::*] { + # foreach tinfo [trace info variable $rv] { + # #puts "-->removing traces on $rv: $tinfo" + # trace remove variable $rv {*}$tinfo + # } + #} + + #!todo - write tests + #refs create aliases and variables at the same place + #- but variable may not exist if it was never set e.g if it was only used with info exists + foreach rv [info commands ::p::${OID}::_ref::*] { + foreach tinfo [trace info variable $rv] { + #puts "-->removing traces on $rv: $tinfo" + trace remove variable $rv {*}$tinfo + } + } + + + + + + + + #if {[catch {namespace delete $nsMeta} msg]} { + # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " + #} else { + # #puts stderr "------ -- -- -- -- deleted $nsMeta " + #} + + + #!todo - remove + #temp + #catch {interp alias "" ::>$OID ""} + + if {$force} { + #rename $cmd {} + + #removing the alias will remove the command - even if it's been renamed + interp alias {} $alias {} + + #if {[catch {rename $_cmd {} } why]} { + # #!todo - work out why some objects don't have matching command. + # #puts stderr "\t rename $_cmd {} failed" + #} else { + # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" + #} + + } + + set refns ::p::${OID}::_ref + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- matching command: [llength [info commands ${refns}]]" + #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" + + + #foreach v [info vars ${refns}::*] { + # unset $v + #} + #foreach p [info procs ${refns}::*] { + # rename $p {} + #} + #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { + # interp alias {} $a {} + #} + + + #set ts1 [clock seconds] + #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." + #puts "- children: [llength [namespace children $refns]]" + #puts "- vars : [llength [info vars ${refns}::*]]" + + #puts "- commands: [llength [info commands ${refns}::*]]" + #puts "- procs : [llength [info procs ${refns}::*]]" + #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" + #puts "- exact command: [info commands ${refns}]" + + + + + #puts "--delete ::p::${OID}::_ref" + if {[namespace exists ::p::${OID}::_ref]} { + #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. + namespace delete ::p::${OID}::_ref:: + } + set ts2 [clock seconds] + #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" + + + #delete namespace where instance variables reside + #catch {namespace delete ::p::$OID} + namespace delete ::p::$OID + + #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout + return +} + + +interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility + + +dict set ::p::-1::_iface::o_methods Destructor {arglist {args}} +#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction? +#install a Destructor on the invocant's open level1 interface. +proc ::p::-1::Destructor {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + #lassign [lindex $map 0] OID alias itemCmd cmd + + set patterns [dict get $MAP interfaces level1] + + if {[llength $args] > 2} { + error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" + } + + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + error "NOT TESTED" + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + #::p::predator::remap $invocant + } + + + set ::p::${IID}::_iface::o_destructor_body [lindex $args end] + + if {[llength $args] > 1} { + #!todo - allow destructor args(?) + set arglist [lindex $args 0] + } else { + set arglist [list] + } + + set ::p::${IID}::_iface::o_destructor_args $arglist + + return +} + + + + + +interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit) + + +dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}} +proc ::p::-1::PatternMethod {_ID_ method arglist body} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + + namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 + + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + #puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls" + set body $varDecls\n[dict get $processed body] + #puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls" + } + + + set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist] + + #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata\] 3\]" @next@ $next] $body[set body {}]\n] + #puts "\t\t--------------------" + #puts "\n" + #puts $body + #puts "\n" + #puts "\t\t--------------------" + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + + + #pointer from method-name to head of the interface's command-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + + if {$method in [dict keys $o_methods]} { + #error "patternmethod '$method' already present in interface $IID" + set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)" + if {[string match "*@next@*" $body]} { + append msg "\n EXTRA-WARNING: method contains @next@" + } + + puts stdout $msg + } else { + dict set o_methods $method [list arglist $arglist] + } + + #::p::-1::update_invocant_aliases $_ID_ + return +} + +#MultiMethod +#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants +# e.g1 $obj .. MultiMethod add {these 2} $arglist $body +# e.g2 $obj .. MultiMethod add {these n} $arglist $body +# +# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body +# +# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature. +# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature) +# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces) +# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? +# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed? +# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? +# (and how would we define the call order? - presumably as it appears in the conglomerate) +# (or could that be done with a more general method-wrapping mechanism?) +#...should multimethods use some sort of event mechanism, and/or message-passing system? +# +dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}} +proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { + set invocants [dict get $_ID_ i] + + error "not implemented" +} + +dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} +# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- ) +#we can create a method named "." by using the argprotect operator -- +# e.g >x .. Method -- . {args} $body +#It can then be called like so: >x . . +#This is not guaranteed to work and is not in the test suite +#for now we'll just use a highly unlikely string to indicate no argument was supplied +proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped + if {$methodname eq $non_argument_magicstring} { + return $default_method + } else { + set extracted_value [dict get $MAP invocantdata] + lset extracted_value 2 $methodname + dict set MAP invocantdata $extracted_value ;#write modified value back + #update the object's command alias to match + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] + + #! $object_command was initially created as the renamed alias - so we have to do it again + rename $alias $object_command + trace add command $object_command rename [list $object_command .. Rename] + return $methodname + } +} + +dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} +proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { + set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set extracted_patterndata [dict get $MAP patterndata] + set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] + if {$methodname eq $non_argument_magicstring} { + return $pattern_default_method + } else { + dict set extracted_patterndata patterndefaultmethod $methodname + dict set MAP patterndata $extracted_patterndata + return $methodname + } +} + + +dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}} +proc ::p::-1::Method {_ID_ method arglist bodydef args} { + set invocants [dict get $_ID_ i] + + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + set invocant_signature [list] ; + ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. + foreach role [lsort [dict keys $invocants]] { + lappend invocant_signature $role [llength [dict get $invocants $role]] + } + #note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this') + + + + lassign [dict get $MAP invocantdata] OID alias default_method object_command + set interfaces [dict get $MAP interfaces level0] + + + + ################################################################################# + if 0 { + set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface + set prev_open [set ::p::${iid_top}::_iface::o_open] + + set iface ::p::ifaces::>$iid_top + + set f_new 0 + if {![string length $iid_top]} { + set f_new 1 + } else { + if {[$iface . isClosed]} { + set f_new 1 + } + } + if {$f_new} { + #create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + + } + set IID $iid_top + + } + ################################################################################# + + set IID [::p::predator::get_possibly_new_open_interface $OID] + + #upvar 0 ::p::${IID}:: IFACE + + namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces + + + #Interface proc + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID $method] + set headid [expr {$maxversion + 1}] + set THISNAME $method.$headid ;#first version will be $method.1 + + if {$method ni [dict keys $o_methods]} { + dict set o_methods $method [list arglist $arglist] + } + + #next_script will call to lower interface in iStack if we are $method.1 + set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_ + #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<" + + + #implement + #----------------------------------- + set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + set varDecls "" + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls\n[dict get $processed body] + } + + + set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist] + + + + + + + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #if {[string length $varDecls]} { + # puts stdout "\t---------------------------------------------------------------" + # puts stdout "\t----- efficiency warning - implicit var declarations used -----" + # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" + # puts stdout "\t[string map [list \n \t\t\n] $body]" + # puts stdout "\t--------------------------" + #} + #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role + # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. + #(as specified by the @ operator during object conglomeration) + #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] + + #puts stdout "\t\t----------------------------" + #puts stdout "$body" + #puts stdout "\t\t----------------------------" + + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body + + #----------------------------------- + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME + + + #point to the interface command only. The dispatcher will supply the invocant data + #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method + set argvals "" + foreach argspec $arglist { + if {[llength $argspec] == 2} { + set a [lindex $argspec 0] + } else { + set a $argspec + } + if {$a eq "args"} { + append argvals " \{*\}\$args" + } else { + append argvals " \$$a" + } + } + set argvals [string trimleft $argvals] + #this proc directly on the object is not *just* a forwarding proc + # - it provides a context in which the 'uplevel 1' from the running interface proc runs + #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) + + #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + ::p::${IID}::_iface::$method \$_ID_ $argvals + }] + + + if 0 { + if {[llength $argvals]} { + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { + apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ + }] + } else { + + proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { + apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ + }] + + } + } + + + #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { + # ::p::${IID}::_iface::$method \$_ID_ $argvals + #}] + + #todo - for o_varspaces + #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method + #- this should work correctly with the 'uplevel 1' procs in the interfaces + + + if {[string length $o_varspace]} { + if {[string match "::*" $o_varspace]} { + namespace eval $o_varspace {} + } else { + namespace eval ::p::${OID}::$o_varspace {} + } + } + + + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + set colMethods ::p::${OID}::_meta::>colMethods + + if {[namespace which $colMethods] ne ""} { + if {![$colMethods . hasKey $method]} { + $colMethods . add [::p::internals::predator $_ID_ . $method .] $method + } + } + + #::p::-1::update_invocant_aliases $_ID_ + return + #::>pattern .. Create [::>pattern .. Namespace]::>method_??? + #return $method_object +} + + +dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}} +proc ::p::-1::V {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + + + set vlist [list] + foreach IID $ifaces { + dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { + if {[string match $glob $vname]} { + lappend vlist $vname + } + } + } + + + return $vlist +} + +#experiment from http://wiki.tcl.tk/4884 +proc p::predator::pipeline {args} { + set lambda {return -level 0} + foreach arg $args { + set lambda [list apply [dict get { + toupper {{lambda input} {string toupper [{*}$lambda $input]}} + tolower {{lambda input} {string tolower [{*}$lambda $input]}} + totitle {{lambda input} {string totitle [{*}$lambda $input]}} + prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}} + suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}} + } [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]] + } + return $lambda +} + +proc ::p::predator::get_apply_arg_0_oid {} { + set apply_args [lrange [info level 0] 2 end] + puts stderr ">>>>> apply_args:'$apply_args'<<<<" + set invocant [lindex $apply_args 0] + return [lindex [dict get $invocant i this] 0 0] +} +proc ::p::predator::get_oid {} { + #puts stderr "---->> [info level 1] <<-----" + set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 + tailcall lindex [dict get $_ID_ i this] 0 0 +} + +#todo - make sure this is called for all script installations - e.g propertyread etc etc +#Add tests to check code runs in correct namespace +#review - how does 'Varspace' command affect this? +proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} { + #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) + set arglist_apply "" + append arglist_apply "\$_ID_ " + foreach a $arglist { + if {$a eq "args"} { + append arglist_apply "{*}\$args" + } else { + append arglist_apply "\$[lindex $a 0] " + } + } + #!todo - allow fully qualified varspaces + if {[string length $varspace]} { + if {[string match ::* $varspace]} { + return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply" + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n" + return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply" + } + } else { + #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" + #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" + + set script "tailcall apply \[list \{_ID_" + + if {[llength $arglist]} { + append script " $arglist" + } + append script "\} \{" + append script $body + append script "\} ::p::@OID@\] " + append script $arglist_apply + #puts stderr "\n88888888888888888888888888\n\t$script\n" + #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" + #return $script + + + #----------------------------------------------------------------------------- + # 2018 candidates + # + #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled + + + #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) + #faster though. + #return "uplevel 1 \{$body\}" + return "uplevel 1 [list $body]" + #----------------------------------------------------------------------------- + + + + + #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" + #return "uplevel 1 \{$script\}" + + #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail + + + + #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong + + #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns + + + #experiment with different dispatch mechanism (interp alias with 'namespace inscope') + #----------- + #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" + + + #return "uplevel 1 \{$body\}" ;#do nothing + + #---------- + + #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) + + #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body + + #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker + + #return "tailcall " + + + } +} + + +#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies. +#expand 'var' statements inline in method bodies +#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements. +# +#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces +#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches! +# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements. +#Think of var & varspace statments as a form of compile-time 'macro' +# +#caters for 2-element lists as arguments to var statement to allow 'aliasing' +#e.g var o_thing {o_data mydata} +# this will upvar o_thing as o_thing & o_data as mydata +# +proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { + set body {} + + #keep count of any explicit var statments per varspace in 'numDeclared' array + # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements. + + #default varspace is "" + #varspace should only have leading :: if it is an absolute namespace path. + + + foreach ln [split $rawbody \n] { + set trimline [string trim $ln] + + if {$trimline eq "var"} { + #plain var statement alone indicates we don't have any explicit declarations in this branch + # and we don't want implicit declarations for the current varspace either. + #!todo - implement test + + incr numDeclared($varspace) + + #may be further var statements e.g - in other code branches + #return [list body $rawbody varspaces_with_explicit_vars 1] + } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { + + #append body " upvar #0 " + #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " + #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " + + if {$varspace eq ""} { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " + } else { + if {[string match "::*" $varspace]} { + append body " namespace upvar $varspace " + } else { + append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " + } + } + + #any whitespace before or betw var names doesn't matter - about to use as list. + foreach varspec [string range $trimline 4 end] { + lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. + ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " + #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " + + append body "$var $alias " + + } + append body \n + + incr numDeclared($varspace) + } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { + #2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? + #it is assumed there is a single word following the 'varspace' keyword. + set varspace [string trim [string range $trimline 9 end]] + + if {$varspace in [list {{}} {""}]} { + set varspace "" + } + if {[string length $varspace]} { + #set varspace ::${varspace}:: + #no need to initialize numDeclared($varspace) incr will work anyway. + #if {![info exists numDeclared($varspace)]} { + # set numDeclared($varspace) 0 + #} + + if {[string match "::*" $varspace]} { + append body "namespace eval $varspace {} \n" + } else { + append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n" + } + + #puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} " + #append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n" + #append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n" + + #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n" + } + #!review - why? why do we need the magic 'default' name instead of just using the empty string? + #if varspace argument was empty string - leave it alone + } else { + append body $ln\n + } + } + + + + set varspaces [array names numDeclared] + return [list body $body varspaces_with_explicit_vars $varspaces] +} + + + + +#Interface Variables +dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} +proc ::p::-1::IV {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + + #!todo - test + #return [dict keys ::p::${OID}::_iface::o_variables $glob] + + set members [list] + foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { + if {[string match $glob $vname]} { + lappend members $vname + } + } + return $members +} + + +dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}} +proc ::p::-1::Methods {_ID_ {idx ""}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set col ::p::${OID}::_meta::>colMethods + + if {[namespace which $col] eq ""} { + patternlib::>collection .. Create $col + foreach IID $ifaces { + foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { + if {![$col . hasIndex $m]} { + #todo - create some sort of lazy-evaluating method object? + #set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist] + $col . add [::p::internals::predator $_ID_ . $m .] $m + } + } + } + } + + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } +} + +dict set ::p::-1::_iface::o_methods M {arglist {}} +proc ::p::-1::M {_ID_} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set members [list] + foreach IID $ifaces { + foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { + lappend members $m + } + } + return $members +} + + +#review +#Interface Methods +dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}} +proc ::p::-1::IM {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + #set map [dict get $this_info map] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] + +} + + + +dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}} +proc ::p::-1::InterfaceStacks {_ID_} { + upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP + return [dict get $MAP interfaces level0] +} + + +dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}} +proc ::p::-1::PatternStacks {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + return [dict get $MAP interfaces level1] +} + + +#!todo fix. need to account for references which were never set to a value +dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}} +proc ::p::-1::DeletePropertyReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + set refvars [info vars ::p::${OID}::_ref::*] + #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. + foreach rv $refvars { + foreach tinfo [trace info variable $rv] { + set ops {}; set cmd {} + lassign $tinfo ops cmd + trace remove variable $rv $ops $cmd + } + unset $rv + lappend cleared_references $rv + } + + + return [list deleted_property_references $cleared_references] +} + +dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}} +proc ::p::-1::DeleteMethodReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + set cleared_references [list] + + set iflist [dict get $MAP interfaces level0] + set iflist_reverse [lreferse $iflist] + #set iflist [dict get $MAP interfaces level0] + + + set refcommands [info commands ::p::${OID}::_ref::*] + foreach c $refcommands { + set reftail [namespace tail $c] + set field [lindex [split $c +] 0] + set field_is_a_method 0 + foreach IFID $iflist_reverse { + if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { + set field_is_a_method 1 + break + } + } + if {$field_is_a_method} { + #what if it's also a property? + interp alias {} $c {} + lappend cleared_references $c + } + } + + + return [list deleted_method_references $cleared_references] +} + + +dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}} +proc ::p::-1::DeleteReferences {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method this + + set result [dict create] + dict set result {*}[$this .. DeletePropertyReferences] + dict set result {*}[$this .. DeleteMethodReferences] + + return $result +} + +## +#Digest +# +#!todo - review +# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!) +# +#!todo - write tests - check that digest changes when properties of contained objects change value +# +#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method? +# +dict set ::p::-1::_iface::o_methods Digest {arglist {args}} +proc ::p::-1::Digest {_ID_ args} { + set invocants [dict get $_ID_ i] + # md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway. + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] _OID alias default_method this + + + set interface_ids [dict get $MAP interfaces level0] + set IFID0 [lindex $interface_ids end] + + set known_flags {-recursive -algorithm -a -indent} + set defaults {-recursive 1 -algorithm md5 -indent ""} + if {[dict exists $args -a] && ![dict exists $args -algorithm]} { + dict set args -algorithm [dict get $args -a] + } + + set opts [dict merge $defaults $args] + foreach key [dict keys $opts] { + if {$key ni $known_flags} { + error "unknown option $key. Expected only: $known_flags" + } + } + + + set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256} + if {[dict get $opts -algorithm] ni $known_algos} { + error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos" + } + set algo [string tolower [dict get $opts -algorithm]] + + # append comma for each var so that all changes in adjacent vars detectable. + # i.e set x 34; set y 5 + # must be distinguishable from: + # set x 3; set y 45 + + if {[dict get $opts -indent] ne ""} { + set state "" + set indent "[dict get $opts -indent]" + } else { + set state "---\n" + set indent " " + } + append state "${indent}object_command: $this\n" + set indent "${indent} " + + #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state. + append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state. + + + + + #!todo - recurse into 'varspaces' + set varspaces_found [list] + append state "${indent}interfaces:\n" + foreach IID $interface_ids { + append state "${indent} - interface: $IID\n" + namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces + append state "${indent} varspaces:\n" + foreach vs $local_o_varspaces { + if {$vs ni $varspaces_found} { + lappend varspaces_found $vs + append state "${indent} - varspace: $vs\n" + } + } + } + + append state "${indent}vars:\n" + foreach var [info vars ::p::${OID}::*] { + append state "${indent} - [namespace tail $var] : \"" + if {[catch {append state "[set $var]"}]} { + append state "[array get $var]" + } + append state "\"\n" + } + + if {[dict get $opts -recursive]} { + append state "${indent}sub-objects:\n" + set subargs $args + dict set subargs -indent "$indent " + foreach obj [info commands ::p::${OID}::>*] { + append state "[$obj .. Digest {*}$subargs]\n" + } + + append state "${indent}sub-namespaces:\n" + set subargs $args + dict set subargs -indent "$indent " + foreach ns [namespace children ::p::${OID}] { + append state "${indent} - namespace: $ns\n" + foreach obj [info commands ${ns}::>*] { + append state "[$obj .. Digest {*}$subargs]\n" + } + } + } + + + if {$algo in {"" raw none}} { + return $state + } else { + if {$algo eq "md5"} { + package require md5 + return [::md5::md5 -hex $state] + } elseif {$algo eq "sha256"} { + package require sha256 + return [::sha2::sha256 -hex $state] + } elseif {$algo eq "blowfish"} { + package require patterncipher + patterncipher::>blowfish .. Create >b1 + set [>b1 . key .] 12341234 + >b1 . encrypt $state -final 1 + set result [>b1 . ciphertext] + >b1 .. Destroy + + } elseif {$algo eq "blowfish-binary"} { + + } else { + error "can't get here" + } + + } +} + + +dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}} +proc ::p::-1::Variable {_ID_ varname args} { + set invocants [dict get $_ID_ i] + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + #this interface itself is always a co-invocant + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set interfaces [dict get $MAP interfaces level0] + + #set existing_IID [lindex $map 1 0 end] + set existing_IID [lindex $interfaces end] + + set prev_openstate [set ::p::${existing_IID}::_iface::o_open] + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #IID changed + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + + #update original object command + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_openstate + } + + set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface) + + if {[llength $args]} { + #!assume var not already present on interface - it is an error to define twice (?) + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + + + #Implement if there is a default + #!todo - correct behaviour when overlaying on existing object with existing var of this name? + #if {[string length $varspace]} { + # set ::p::${OID}::${varspace}::$varname [lindex $args 0] + #} else { + set ::p::${OID}::$varname [lindex $args 0] + #} + } else { + #lappend ::p::${IID}::_iface::o_variables [list $varname] + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } + + #varspace '_iface' + + return +} + + +#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility + +dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}} +proc ::p::-1::PatternVariable {_ID_ varname args} { + set invocants [dict get $_ID_ i] + + #set invocant_alias [lindex [dict get $invocants this] 0] + #set invocant [lindex [interp alias {} $invocant_alias] 1] + ##this interface itself is always a co-invocant + #lassign [lindex $invocant 0 ] OID alias itemCmd cmd + + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top + + set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. + + + if {[llength $args]} { + #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] + dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] + } else { + dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] + } + + return +} + +dict set ::p::-1::_iface::o_methods Varspaces {arglist args} +proc ::p::-1::Varspaces {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + if {![llength $args]} { + #query + set iid_top [lindex [dict get $MAP interfaces level0] end] + set iface ::p::ifaces::>$iid_top + if {![string length $iid_top]} { + error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " + } elseif {[$iface . isClosed]} { + error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " + } + return [set ::p::${iid_top}::_iface::o_varspaces] + } + set IID [::p::predator::get_possibly_new_open_interface $OID] + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + + set varspaces $args + foreach vs $varspaces { + if {[string length $vs] && ($vs ni $o_varspaces)} { + if {[string match ::* $vs} { + namespace eval $vs {} + } else { + namespace eval ::p::${OID}::$vs {} + } + lappend o_varspaces $vs + } + } + return $o_varspaces +} + +#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface +dict set ::p::-1::_iface::o_methods Varspace {arglist args} +# set the default varspace for the interface, so that new methods/properties refer to it. +# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. +proc ::p::-1::Varspace {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + if {![llength $args]} { + #query + set iid_top [lindex [dict get $MAP interfaces level0] end] + set iface ::p::ifaces::>$iid_top + if {![string length $iid_top]} { + error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " + } elseif {[$iface . isClosed]} { + error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " + } + return [set ::p::${iid_top}::_iface::o_varspace] + } + set varspace [lindex $args 0] + + #set interfaces [dict get $MAP interfaces level0] + #set iid_top [lindex $interfaces end] + + set IID [::p::predator::get_possibly_new_open_interface $OID] + + + #namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + + if {[string length $varspace]} { + #ensure namespace exists !? do after list test? + if {[string match ::* $varspace]} { + namespace eval $varspace {} + } else { + namespace eval ::p::${OID}::$varspace {} + } + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + set o_varspace $varspace +} + + +proc ::p::predator::get_possibly_new_open_interface {OID} { + #we need to re-upvar MAP rather than using a parameter - as we need to write back to it + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #puts stderr ">>>>creating new interface $iid_top" + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + + return $iid_top +} + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}} +# set the default varspace for the interface, so that new methods/properties refer to it. +# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. +proc ::p::-1::PatternVarspace {_ID_ varspace args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces + if {[string length $varspace]} { + if {$varspace ni $o_varspaces} { + lappend o_varspaces $varspace + } + } + #o_varspace is the currently active varspace + set o_varspace $varspace + +} +################################################################################################################################################### + +#get varspace and default from highest interface - return all interface ids which define it +dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}} +proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] + + array set propinfo {} + set found_property_names [list] + #start at the lowest and work up (normal storage order of $interfaces) + foreach iid $interfaces { + set propinfodict [set ::p::${iid}::_iface::o_properties] + set matching_propnames [dict keys $propinfodict $propnamepattern] + foreach propname $matching_propnames { + if {$propname ni $found_property_names} { + lappend found_property_names $propname + } + lappend propinfo($propname,interfaces) $iid + ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one + if {[dict exists $propinfodict $propname default]} { + set propinfo($propname,default) [dict get $propinfodict $propname default] + } + set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] + } + } + + set resultdict [dict create] + foreach propname $found_property_names { + set fields [list varspace $propinfo($propname,varspace)] + if {[array exists propinfo($propname,default)]} { + lappend fields default [set propinfo($propname,default)] + } + lappend fields interfaces $propinfo($propname,interfaces) + dict set resultdict $propname $fields + } + return $resultdict +} + + +dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args} +proc ::p::-1::GetTopPattern {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level1] + set iid_top [lindex $interfaces end] + if {![string length $iid_top]} { + lassign [dict get $MAP invocantdata] OID _alias _default_method object_command + error "No installed level1 interfaces (patterns) for object $object_command" + } + return ::p::ifaces::>$iid_top +} + + + +dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args} +proc ::p::-1::GetTopInterface {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set iid_top [lindex [dict get $MAP interfaces level0] end] + if {![string length $iid_top]} { + lassign [dict get $MAP invocantdata] OID _alias _default_method object_command + error "No installed level0 interfaces for object $object_command" + } + return ::p::ifaces::>$iid_top +} + + +dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} +proc ::p::-1::GetExpandableInterface {_ID_ args} { + +} + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods Property {arglist {property args}} +proc ::p::-1::Property {_ID_ property args} { + #puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args" + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + if {[llength $args] > 1} { + error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)" + } + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set interfaces [dict get $MAP interfaces level0] + set iid_top [lindex $interfaces end] + + set prev_openstate [set ::p::${iid_top}::_iface::o_open] + + set iface ::p::ifaces::>$iid_top + + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat $interfaces $iid_top] + dict set MAP interfaces $extracted_sub_dict + } + set IID $iid_top + + + namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + + + if {$headid == 1} { + #implementation + #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property + + #if {$o_varspace eq ""} { + # set ns ::p::${OID} + #} else { + # if {[string match "::*" $o_varspace]} { + # set ns $o_varspace + # } else { + # set ns ::p::${OID}::$o_varspace + # } + #} + #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]] + + proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]] + + + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property + proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] + + + #chainhead pointers + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 + + + } + + if {($property ni [dict keys $o_methods])} { + interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property + } + + + + #installation on object + + #namespace eval ::p::${OID} [list namespace export $property] + + + + #obsolete? + #if {$property ni [P $_ID_]} { + #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces + #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant + #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant + #} + + #link main (GET)/(SET) to this interface + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property + interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property + + #Only install property if no method of same name already installed here. + #(Method takes precedence over property because property always accessible via 'set' reference) + #convenience pointer to chainhead pointer. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } else { + #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed + + + } + + + set varspace [set ::p::${IID}::_iface::o_varspace] + + + + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} + dict set o_variables o_$property [list varspace $varspace] + + + + + if {[llength $args]} { + #should store default once only! + #set IFINFO(v,default,o_$property) $default + + set default [lindex $args end] + + dict set o_properties $property [list default $default varspace $varspace] + + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { + # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] + #} else { + # lappend o_properties [list $property $default] + #} + + if {$varspace eq ""} { + set ns ::p::${OID} + } else { + if {[string match "::*" $varspace]} { + set ns $varspace + } else { + set ns ::p::${OID}::$o_varspace + } + } + + set ${ns}::o_$property $default + #set ::p::${OID}::o_$property $default + } else { + + #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { + # set o_properties [lreplace $o_properties $posn $posn [list $property]] + #} else { + # lappend o_properties [list $property] + #} + dict set o_properties $property [list varspace $varspace] + + + #variable ::p::${OID}::o_$property + } + + + + + + #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. + #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) + #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} + + set colProperties ::p::${OID}::_meta::>colProperties + if {[namespace which $colProperties] ne ""} { + if {![$colProperties . hasKey $property]} { + $colProperties . add [::p::internals::predator $_ID_ . $property .] $property + } + } + + return +} +################################################################################################################################################### + + + +################################################################################################################################################### + +################################################################################################################################################### +interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility +dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}} +proc ::p::-1::PatternProperty {_ID_ property args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + set patterns [dict get $MAP interfaces level1] + set iid_top [lindex $patterns end] + + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat $patterns $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat $patterns $iid_top] + } + set IID $iid_top + + namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + + + + if {$headid == 1} { + #implementation + #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property + proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]] + #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property + proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] + + + #chainhead pointers + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 + + } + + if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} { + interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property + } + + set varspace [set ::p::${IID}::_iface::o_varspace] + + #Install the matching Variable + #!todo - which should take preference if Variable also given a default? + #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { + # set o_variables [lreplace $o_variables $posn $posn o_$property] + #} else { + # lappend o_variables [list o_$property] + #} + dict set o_variables o_$property [list varspace $varspace] + + set argc [llength $args] + + if {$argc} { + if {$argc == 1} { + set default [lindex $args 0] + dict set o_properties $property [list default $default varspace $varspace] + } else { + #if more than one arg - treat as a dict of options. + if {[dict exists $args -default]} { + set default [dict get $args -default] + dict set o_properties $property [list default $default varspace $varspace] + } else { + #no default value + dict set o_properties $property [list varspace $varspace] + } + } + #! only set default for property... not underlying variable. + #lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]] + } else { + dict set o_properties $property [list varspace $varspace] + } + return +} +################################################################################################################################################### + + + + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}} +proc ::p::-1::PatternPropertyRead {_ID_ property args} { + set invocants [dict get $_ID_ i] + + set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' + set OID [lindex $this_invocant 0] + #set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias defaut_command cmd + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + if {$headid == 1} { + set headid 2 ;#reserve 1 for the getprop of the underlying property + } + + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ + + + #implement + #----------------------------------- + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + #implementation + if {![llength $idxlist]} { + proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body + } else { + #what are we trying to achieve here? .. + proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body + } + + + #----------------------------------- + + + #adjust chain-head pointer to point to new head. + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + return +} +################################################################################################################################################### + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}} +proc ::p::-1::PropertyRead {_ID_ property args} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + + #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead) + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] + + + set idxlist [::list] + if {[llength $args] == 1} { + set body [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args idxlist body + } else { + error "wrong # args: should be \"property body\" or \"property idxlist body\"" + } + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd] + + + set maxversion [::p::predator::method_chainhead $IID (GET)$property] + set headid [expr {$maxversion + 1}] + if {$headid == 1} { + set headid 2 + } + set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself) + + set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body + + #----------------------------------- + + + + #pointer from prop-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid + + + interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name. + if {$property ni [M $_ID_]} { + interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property + } +} +################################################################################################################################################### + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}} +proc ::p::-1::PropertyWrite {_ID_ property argname body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. + + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + set ::p::${IID}::_iface::o_open 0 + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace + + #pw short for propertywrite + #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] + + + set maxversion [::p::predator::method_chainhead $IID (SET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (SET)$property.$headid + + set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] + + #implement + #----------------------------------- + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + + proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body + + #----------------------------------- + + + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid +} +################################################################################################################################################### + + + + + + + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}} +proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set existing_ifaces [lindex $map 1 1] + set posn [lsearch $existing_ifaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] + + #set ::p::${IID}::_iface::o_open 0 + } else { + } + + #pw short for propertywrite + array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] + + + + + return + +} +################################################################################################################################################### + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}} +proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_command cmd + + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + } else { + set prev_open [set ::p::${existing_IID}::_iface::o_open] + set ::p::${IID}::_iface::o_open $prev_open + } + namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers + #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] + set headid [expr {$maxversion + 1}] + + set THISNAME (UNSET)$property.$headid + + set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] + + + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + if {[llength [dict get $processed varspaces_with_explicit_vars]]} { + foreach vs [dict get $processed varspaces_with_explicit_vars] { + if {[string length $vs] && ($vs ni $o_varspaces)} { + lappend o_varspaces $vs + } + } + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. + set body $varDecls[dict get $processed body] + } + #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + + #note $arraykeypattern actually contains the name of the argument + if {[string trim $arraykeypattern] eq ""} { + set arraykeypattern _dontcare_ ;# + } + proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body + + #----------------------------------- + + + #pointer from method-name to head of override-chain + interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid + +} +################################################################################################################################################### + + + + + + + + +################################################################################################################################################### + +################################################################################################################################################### +dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}} +proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #set ::p::${IID}::_iface::o_open 0 + } + + + upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers + dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] + + return +} +################################################################################################################################################### + + + +#lappend ::p::-1::_iface::o_methods Implements +#!todo - some way to force overriding of any abstract (empty) methods from the source object +#e.g leave interface open and raise an error when closing it if there are unoverridden methods? + + + + + +#implementation reuse - sugar for >object .. Clone >target +dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}} +proc ::p::-1::Extends {_ID_ pattern} { + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'Extends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Clone $object_command + +} +#implementation reuse - sugar for >pattern .. Create >target +dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}} +proc ::p::-1::PatternExtends {_ID_ pattern} { + if {!([string range [namespace tail $pattern] 0 0] eq ">")} { + error "'PatternExtends' expected a pattern object" + } + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd object_command + + + tailcall $pattern .. Create $object_command +} + + +dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}} +proc ::p::-1::Extend {_ID_ {idx ""}} { + puts stderr "Extend is DEPRECATED - use Expand instead" + tailcall ::p::-1::Expand $_ID_ $idx +} + +#set the topmost interface on the iStack to be 'open' +dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}} +proc ::p::-1::Expand {_ID_ {idx ""}} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set iid_top [lindex $interfaces end] + set iface ::p::ifaces::>$iid_top + + if {![string length $iid_top]} { + #no existing interface - create a new one + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [list $iid_top] + dict set MAP interfaces $extracted_sub_dict ;#write new interface into map + $iface . open + return $iid_top + } else { + if {[$iface . isOpen]} { + #already open.. + #assume ready to expand.. shared or not! + return $iid_top + } + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + if {[$iface . refCount] > 1} { + if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} { + #!warning! not exercised by test suites! + + #remove ourself from the usedby list of the previous interface + array unset ::p::${iid_top}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + #remove existing interface & add + set posn [lsearch $interfaces $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + + set iid_top $IID + set iface ::p::ifaces::>$iid_top + } + } + } + + $iface . open + return $iid_top +} + +dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}} +proc ::p::-1::PatternExtend {_ID_ {idx ""}} { + puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead" + tailcall ::p::-1::PatternExpand $_ID_ $idx +} + + + +#set the topmost interface on the pStack to be 'open' if it's not shared +# if shared - 'copylink' to new interface before opening for extension +dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}} +proc ::p::-1::PatternExpand {_ID_ {idx ""}} { + set OID [::p::obj_get_this_oid $_ID_] + ::p::map $OID MAP + #puts stderr "no tests written for PatternExpand " + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces + set iid_top [lindex $ifaces end] + set iface ::p::ifaces::>$iid_top + + if {![string length $iid_top]} { + #no existing interface - create a new one + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [list $iid_top] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [list $iid_top] + $iface . open + return $iid_top + } else { + if {[$iface . isOpen]} { + #already open.. + #assume ready to expand.. shared or not! + return $iid_top + } + + if {[$iface . refCount] > 1} { + if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} { + #!WARNING! not exercised by test suite! + #remove ourself from the usedby list of the previous interface + array unset ::p::${iid_top}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $ifaces $iid_top] + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID] + + set iid_top $IID + set iface ::p::ifaces::>$iid_top + } + } + } + + $iface . open + return $iid_top +} + + + + + +dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}} +proc ::p::-1::Properties {_ID_ {idx ""}} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set col ::p::${OID}::_meta::>colProperties + + if {[namespace which $col] eq ""} { + patternlib::>collection .. Create $col + foreach IID $ifaces { + dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] { + if {![$col . hasIndex $prop]} { + $col . add [::p::internals::predator $_ID_ . $prop .] $prop + } + } + } + } + + if {[string length $idx]} { + return [$col . item $idx] + } else { + return $col + } +} + +dict set ::p::-1::_iface::o_methods P {arglist {}} +proc ::p::-1::P {_ID_} { + set invocants [dict get $_ID_ i] + set this_invocant [lindex [dict get $invocants this] 0] + lassign $this_invocant OID _etc + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces + + set members [list] + foreach IID $interfaces { + foreach prop [dict keys [set ::p::${IID}::_iface::o_properties]] { + lappend members $prop + } + } + return [lsort $members] + +} +#Interface Properties +dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}} +proc ::p::-1::IP {_ID_ {glob *}} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces + set members [list] + + foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { + if {[string match $glob [lindex $m 0]]} { + lappend members [lindex $m 0] + } + } + return $members +} + + +#used by rename.test - theoretically should be on a separate interface! +dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}} +proc ::p::-1::CheckInvocants {_ID_ args} { + #check all invocants in the _ID_ are consistent with data stored in their MAP variable + set status "ok" ;#default to optimistic assumption + set problems [list] + + set invocant_dict [dict get $_ID_ i] + set invocant_roles [dict keys $invocant_dict] + + foreach role $invocant_roles { + set invocant_list [dict get $invocant_dict $role] + foreach aliased_invocantdata $invocant_list { + set OID [lindex $aliased_invocantdata 0] + set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] + #we use lrange to make sure the lists are in canonical form + if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { + set status "not-ok" + lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] + } + } + + } + + + set result [dict create] + dict set result status $status + dict set result problems $problems + + return $result +} + + +#get or set t +dict set ::p::-1::_iface::o_methods Namespace {arglist {args}} +proc ::p::-1::Namespace {_ID_ args} { + #set invocants [dict get $_ID_ i] + #set this_invocant [lindex [dict get $invocants this] 0] + #lassign $this_invocant OID this_info + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + set IID [lindex [dict get $MAP interfaces level0] end] + + namespace upvar ::p::${IID}::_iface o_varspace active_varspace + + if {[string length $active_varspace]} { + set ns ::p::${OID}::$active_varspace + } else { + set ns ::p::${OID} + } + + #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object? + # - should .. Namespace be usable at all from outside the object? + + + if {[llength $args]} { + #special case some of the namespace subcommands. + + #delete + if {[string match "d*" [lindex $args 0]]} { + error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object." + } + #upvar,ensemble,which,code,origin,expor,import,forget + if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} { + return [namespace eval $ns [list namespace {*}$args]] + } + #current + if {[string match "cu*" [lindex $args 0]]} { + return $ns + } + + #children,eval,exists,inscope,parent,qualifiers,tail + return [namespace {*}[linsert $args 1 $ns]] + } else { + return $ns + } +} + + + + + + + + + + +dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}} +proc ::p::-1::PatternUnknown {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + set patterns [dict get $MAP interfaces level1] + set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $patterns $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] + #::p::predator::remap $invocant + } + + set handlermethod [lindex $args 0] + + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } + +} + + + +dict set ::p::-1::_iface::o_methods Unknown {arglist {args}} +proc ::p::-1::Unknown {_ID_ args} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + + set interfaces [dict get $MAP interfaces level0] + set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. + + set prev_open [set ::p::${existing_IID}::_iface::o_open] + + if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { + #remove ourself from the usedby list of the previous interface + array unset ::p::${existing_IID}::_iface::o_usedby i$OID + set ::p::${IID}::_iface::o_usedby(i$OID) $cmd + + set posn [lsearch $interfaces $existing_IID] + + set extracted_sub_dict [dict get $MAP interfaces] + dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] + dict set MAP interfaces $extracted_sub_dict + #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] + + set ::p::${IID}::_iface::o_open 0 + } else { + set ::p::${IID}::_iface::o_open $prev_open + } + + set handlermethod [lindex $args 0] + + if {[llength $args]} { + set ::p::${IID}::_iface::o_unknown $handlermethod + #set ::p::${IID}::(unknown) $handlermethod + + + #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod + interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod + interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod + + #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod] + #namespace eval ::p::${OID} [list namespace unknown $handlermethod] + + return + } else { + set ::p::${IID}::_iface::o_unknown $handlermethod + } + +} + + +#useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []' +# should also work for non-object results +dict set ::p::-1::_iface::o_methods As {arglist {varname}} +proc ::p::-1::As {_ID_ varname} { + set invocants [dict get $_ID_ i] + #puts stdout "invocants: $invocants" + #!todo - handle multiple invocants with other roles, not just 'this' + + set OID [lindex [dict get $_ID_ i this] 0 0] + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + tailcall set $varname $cmd + } else { + #puts stdout "info level 1 [info level 1]" + set role_members [dict get $_ID_ i this] + if {[llength $role_members] == 1} { + set member [lindex $role_members 0] + lassign $member _OID namespace default_method stackvalue _wrapped + tailcall set $varname $stackvalue + } else { + #multiple invocants - return all results as a list + set resultlist [list] + foreach member $role_members { + lassign $member _OID namespace default_method stackvalue _wrapped + lappend resultlist $stackvalue + } + tailcall set $varname $resultlist + } + } +} + +#!todo - AsFileStream ?? +dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}} +proc ::p::-1::AsFile {_ID_ filename args} { + dict set default -force 0 + dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object + set opts [dict merge $default $args] + set force [dict get $opts -force] + set dumpmethod [dict get $opts -dumpmethod] + + + if {[file pathtype $filename] eq "relative"} { + set filename [pwd]/$filename + } + set filedir [file dirname $filename] + if {![sf::file_writable $filedir]} { + error "(method AsFile) ERROR folder $filedir is not writable" + } + if {[file exists $filename]} { + if {!$force} { + error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite" + } + if {![sf::file_writable $filename]} { + error "(method AsFile) ERROR file $filename is not writable - check permissions" + } + } + set fd [open $filename w] + fconfigure $fd -translation binary + + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $_ID_ i this] 0 0] + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + #tailcall set $varname $cmd + set object_data [$cmd {*}$dumpmethod] + puts -nonewline $fd $object_data + close $fd + return [list status 1 bytes [string length $object_data] filename $filename] + } else { + #puts stdout "info level 1 [info level 1]" + set role_members [dict get $_ID_ i this] + if {[llength $role_members] == 1} { + set member [lindex $role_members 0] + lassign $member _OID namespace default_method stackvalue _wrapped + puts -nonewline $fd $stackvalue + close $fd + #tailcall set $varname $stackvalue + return [list status 1 bytes [string length $stackvalue] filename $filename] + } else { + #multiple invocants - return all results as a list + set resultlist [list] + foreach member $role_members { + lassign $member _OID namespace default_method stackvalue _wrapped + lappend resultlist $stackvalue + } + puts -nonewline $fd $resultset + close $fd + return [list status 1 bytes [string length $resultset] filename $filename] + #tailcall set $varname $resultlist + } + } + +} + + + +dict set ::p::-1::_iface::o_methods Object {arglist {}} +proc ::p::-1::Object {_ID_} { + set invocants [dict get $_ID_ i] + set OID [lindex [dict get $invocants this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + set result [string map [list ::> ::] $cmd] + if {![catch {info level -1} prev_level]} { + set called_by "(called by: $prev_level)" + } else { + set called_by "(called by: interp?)" + + } + + puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" + puts stdout " (returning $result)" + + return $result +} + +#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname +dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} +proc ::p::-1::MakeAlias {_ID_cmdname } { + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias itemCmd cmd + + error "concept probably won't work - try making dispatcher understand trailing '= cmdname' " +} +dict set ::p::-1::_iface::o_methods ID {arglist {}} +proc ::p::-1::ID {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + return $OID +} + +dict set ::p::-1::_iface::o_methods IFINFO {arglist {}} +proc ::p::-1::IFINFO {_ID_} { + puts stderr "--_ID_: $_ID_--" + set OID [::p::obj_get_this_oid $_ID_] + upvar #0 ::p::${OID}::_meta::map MAP + + puts stderr "-- MAP: $MAP--" + + set interfaces [dict get $MAP interfaces level0] + set IFID [lindex $interfaces 0] + + if {![llength $interfaces]} { + puts stderr "No interfaces present at level 0" + } else { + foreach IFID $interfaces { + set iface ::p::ifaces::>$IFID + puts stderr "$iface : [$iface --]" + puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" + set variables [set ::p::${IFID}::_iface::o_variables] + puts stderr "\tvariables: $variables" + } + } + +} + + + + +dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} +proc ::p::-1::INVOCANTDATA {_ID_} { + #same as a call to: >object .. + return $_ID_ +} + +#obsolete? +dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}} +proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} { + set updated_ID_ $_ID_ + array set updated_roles [list] + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + foreach role $invocant_roles { + + set role_members [dict get $invocants $role] + foreach member [dict get $invocants $role] { + #each member is a 2-element list consisting of the OID and a dictionary + #each member is a 5-element list + #set OID [lindex $member 0] + #set object_dict [lindex $member 1] + lassign $member OID alias itemcmd cmd wrapped + + set MAP [set ::p::${OID}::_meta::map] + #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} + + if {[dict get $MAP invocantdata] eq $member} + #same - nothing to do + + } else { + package require overtype + puts stderr "---------------------------------------------------------" + puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" + set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] + puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" + puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" + puts stderr "---------------------------------------------------------" + #take _meta::map version + lappend updated_roles($role) [dict get $MAP invocantdata] + } + + } + + #overwrite changed roles only + foreach role [array names updated_roles] { + dict set updated_ID_ i $role [set updated_roles($role)] + } + + return $updated_ID_ +} + + + +dict set ::p::-1::_iface::o_methods INFO {arglist {}} +proc ::p::-1::INFO {_ID_} { + set result "" + append result "_ID_: $_ID_\n" + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + append result "invocant roles: $invocant_roles\n" + set total_invocants 0 + foreach key $invocant_roles { + incr total_invocants [llength [dict get $invocants $key]] + } + + append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" + foreach key $invocant_roles { + append result "\t-------------------------------\n" + append result "\trole: $key\n" + set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants + append result "\t Raw data for this role: $role_members\n" + append result "\t Number of invocants in this role: [llength $role_members]\n" + foreach member $role_members { + #set OID [lindex [dict get $invocants $key] 0 0] + set OID [lindex $member 0] + append result "\t\tOID: $OID\n" + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + append result "\t\tmap:\n" + foreach key [dict keys $MAP] { + append result "\t\t\t$key\n" + append result "\t\t\t\t [dict get $MAP $key]\n" + append result "\t\t\t----\n" + } + lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped + append result "\t\tNamespace: $namespace\n" + append result "\t\tDefault method: $default_method\n" + append result "\t\tCommand: $cmd\n" + append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n" + append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n" + append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n" + } else { + lassign $member _OID namespace default_method stackvalue _wrapped + append result "\t\t last item on the predator stack is a value not an object" + append result "\t\t Value is: $stackvalue" + + } + } + append result "\n" + append result "\t-------------------------------\n" + } + + + + return $result +} + + + + +dict set ::p::-1::_iface::o_methods Rename {arglist {args}} +proc ::p::-1::Rename {_ID_ args} { + set OID [::p::obj_get_this_oid $_ID_] + if {![llength $args]} { + error "Rename expected \$newname argument" + } + + #Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant? + upvar #0 ::p::${OID}::_meta::map MAP + + + + #puts ">>.>> Rename. _ID_: $_ID_" + + if {[catch { + + if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { + + #appears to be a 'trace command rename' firing + #puts "\t>>>> rename trace fired $MAP $args <<<" + + lassign $args oldcmd newcmd + set extracted_invocantdata [dict get $MAP invocantdata] + lset extracted_invocantdata 3 $newcmd + dict set MAP invocantdata $extracted_invocantdata + + + lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped + + #Write the same info into the _ID_ value of the alias + interp alias {} $alias {} ;#first we must delete it + interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] + + + + #! $object_command was initially created as the renamed alias - so we have to do it again + uplevel 1 [list rename $alias $object_command] + trace add command $object_command rename [list $object_command .. Rename] + + } elseif {[llength $args] == 1} { + #let the rename trace fire and we will be called again to do the remap! + uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] + } else { + error "Rename expected \$newname argument ." + } + + } errM]} { + puts stderr "\t@@@@@@ rename error" + set ruler "\t[string repeat - 80]" + puts stderr $ruler + puts stderr $errM + puts stderr $ruler + + } + + return + + +} + +proc ::p::obj_get_invocants {_ID_} { + return [dict get $_ID_ i] +} +#The invocant role 'this' is special and should always have only one member. +# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX +proc ::p::obj_get_this_oid {_ID_} { + return [lindex [dict get $_ID_ i this] 0 0] +} +proc ::p::obj_get_this_ns {_ID_} { + return [lindex [dict get $_ID_ i this] 0 1] +} + +proc ::p::obj_get_this_cmd {_ID_} { + return [lindex [dict get $_ID_ i this] 0 3] +} +proc ::p::obj_get_this_data {_ID_} { + lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd + #set this_invocant_data {*}[dict get $_ID_ i this] + return [list oid $OID ns $ns cmd $cmd] +} +proc ::p::map {OID varname} { + tailcall upvar #0 ::p::${OID}::_meta::map $varname +} + + + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.0.tm deleted file mode 100644 index fd6b00ec..00000000 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.0.tm +++ /dev/null @@ -1,705 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2024 -# -# @@ Meta Begin -# Application modpod 0.1.0 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.0] -#[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require modpod] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of modpod -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by modpod -#[list_begin itemized] - -package require Tcl 8.6- -package require struct::set ;#review -package require punk::lib -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::class { - #*** !doctools - #[subsection {Namespace modpod::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod { - namespace export {[a-z]*}; # Convention: export all lowercase - - variable connected - if {![info exists connected(to)]} { - set connected(to) list - } - variable modpodscript - set modpodscript [info script] - if {[string tolower [file extension $modpodscript]] eq ".tcl"} { - set connected(self) [file dirname $modpodscript] - } else { - #expecting a .tm - set connected(self) $modpodscript - } - variable loadables [info sharedlibextension] - variable sourceables {.tcl .tk} ;# .tm ? - - #*** !doctools - #[subsection {Namespace modpod}] - #[para] Core API functions for modpod - #[list_begin definitions] - - - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - proc connect {args} { - puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { - -type -default "" - *values -min 1 -max 1 - path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" - } $args] - catch { - punk::lib::showdict $argd ;#heavy dependencies - } - set opt_path [dict get $argd values path] - variable connected - set original_connectpath $opt_path - set modpodpath [modpod::system::normalize $opt_path] ;# - - if {$modpodpath in $connected(to)} { - return [dict create ok ALREADY_CONNECTED] - } - lappend connected(to) $modpodpath - - set connected(connectpath,$opt_path) $original_connectpath - set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info_script]]}] - - set connected(location,$modpodpath) [file dirname $modpodpath] - set connected(startdata,$modpodpath) -1 - set connected(type,$modpodpath) [dict get $argd-opts -type] - set connected(fh,$modpodpath) "" - - if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { - set connected(type,$modpodpath) "unwrapped" - lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] - - } else { - #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname $modpodpath] - if {$connected(type,$modpodpath) ne "unwrapped"} { - #Not directly connected to unwrapped version - but may still be redirected there - set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] - if {[file exists $unwrappedFolder]} { - #folder with exact version-match must exist for redirect to 'unwrapped' - set con(type,$modpodpath) "modpod-redirecting" - } - } - - } - set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" - set connected(tmfile,$modpodpath) - set tail_segments [list] - set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] - break - } - } - if {[llength $tail_segments]} { - set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require - } else { - set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] - } - - switch -exact -- $connected(type,$modpodpath) { - "modpod-redirecting" { - #redirect to the unwrapped version - set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] - - } - "unwrapped" { - if {[info commands ::thread::id] ne ""} { - set from [pid],[thread::id] - } else { - set from [pid] - } - #::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" - return [list ok ""] - } - default { - #autodetect .tm - zip/tar ? - #todo - use vfs ? - - #connect to tarball - start at 1st header - set connected(startdata,$modpodpath) 0 - set fh [open $modpodpath r] - set connected(fh,$modpodpath) $fh - fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} - - if {$connected(startdata,$modpodpath) >= 0} { - #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { - seek $fh $connected(startdata,$modpodpath) start - return [list ok $fh] - } else { - #error "cannot verify tar header" - } - } - lpop connected(to) end - set connected(startdata,$modpodpath) -1 - unset connected(fh,$modpodpath) - catch {close $fh} - return [dict create err {Does not appear to be a valid modpod}] - } - } - } - proc disconnect {{modpod ""}} { - variable connected - if {![llength $connected(to)]} { - return 0 - } - if {$modpod eq ""} { - puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" - set modpod [lindex $connected(to) end] - } - - if {[set posn [lsearch $connected(to) $modpod]] == -1} { - puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" - return 0 - } - if {[string length $connected(fh,$modpod)]} { - close $connected(fh,$modpod) - } - array unset connected *,$modpod - set connected(to) [lreplace $connected(to) $posn $posn] - return 1 - } - proc get {args} { - set argd [punk::args::get_dict { - -from -default "" -help "path to pod" - *values -min 1 -max 1 - filename - } $args] - set frompod [dict get $argd opts -from] - set filename [dict get $argd values filename] - - variable connected - set modpod [::tarjar::system::connect_if_not $frompod] - set fh $connected(fh,$modpod) - if {$connected(type,$modpod) eq "unwrapped"} { - #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder - if {[string range $filename 0 0 eq "/"]} { - #absolute path (?) - set path [file join $connected(location,$modpod) .. [string trim $filename /]] - } else { - #relative path - use #modpod-xxx as base - set path [file join $connected(location,$modpod) $filename] - } - set fd [open $path r] - #utf-8? - #fconfigure $fd -encoding iso8859-1 -translation binary - return [list ok [lindex [list [read $fd] [close $fd]] 0]] - } else { - #read from vfs - puts stderr "get $filename from wrapped pod '$frompod' not implemented" - } - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::lib { - namespace export {[a-z]*}; # Convention: export all lowercase - namespace path [namespace parent] - #*** !doctools - #[subsection {Namespace modpod::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - proc is_valid_tm_version {versionpart} { - #Needs to be suitable for use with Tcl's 'package vcompare' - if {![catch [list package vcompare $versionparts $versionparts]]} { - return 1 - } else { - return 0 - } - } - proc make_zip_modpod {zipfile outfile} { - set mount_stub { - #zip file with Tcl loader prepended. - #generated using modpod::make_zip_modpod - if {[catch {file normalize [info script]} modfile]} { - error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" - } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #determine module namespace so we can mount appropriately - proc intersect {A B} { - if {[llength $A] == 0} {return {}} - if {[llength $B] == 0} {return {}} - if {[llength $B] > [llength $A]} { - set res $A - set A $B - set B $res - } - set res {} - foreach x $A {set ($x) {}} - foreach x $B { - if {[info exists ($x)]} { - lappend res $x - } - } - return $res - } - set lcase_tmfile_segments [string tolower [file split $moddir]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use propertly cased tail - break - } - } - if {[llength $tail_segments]} { - set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require - set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver - } else { - set fullpackage $moduletail - set mount_at #modpod/#mounted-modpod-$mod_and_ver - } - - if {[info commands tcl::zipfs::mount] ne ""} { - #argument order changed to be consistent with vfs::zip::Mount etc - #early versions: zipfs::Mount mountpoint zipname - #since 2023-09: zipfs::Mount zipname mountpoint - #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) - #This is presumably related to // being interpreted as a network path - set mountpoints [dict keys [tcl::zipfs::mount]] - if {"//zipfs:/$mount_at" ni $mountpoints} { - #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it - if {[catch { - #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) - #puts "tcl::zipfs::mount $modfile $mount_at" - tcl::zipfs::mount $modfile $mount_at - } errM]} { - #try old api - if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { - puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" - puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" - } - } - if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" - #tcl::zipfs::unmount //zipfs:/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form - source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #fallback to slower vfs::zip - #NB. We don't create the intermediate dirs - but the mount still works - if {![file exists $moddir/$mount_at]} { - if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver" - append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." - append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" - error $msg - } else { - set fd [vfs::zip::Mount $modfile $moddir/$mount_at] - if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - } - source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } - } - #zipped data follows - } - #todo - test if zipfile has #modpod-loadcript.tcl before even creating - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub - - } - proc make_zip_modpod1 {zipfile outfile} { - set mount_stub { - #zip file with Tcl loader prepended. - #generated using modpod::make_zip_modpod - if {[catch {file normalize [info script]} modfile]} { - error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" - } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - if {![file exists $moddir/#mounted-modpod-$mod_and_ver]} { - if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver" - append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." - append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $ - } - set fd [vfs::zip::Mount $modfile $moddir/#mounted-modpod-$mod_and_ver] - if {![file exists $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/#mounted-modpod-$mod_and_ver - error "Unable to find #modpod-$mod_and_ver/$mod_and_ver.tm in $modfile" - } - } - source $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm - } - #zipped data follows - } - #todo - test if zipfile has #modpod-loadcript.tcl before even creating - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub - - } - proc make_zip_source_mountable {zipfile outfile} { - set mount_stub { - package require vfs::zip - vfs::zip::Mount [info script] [info script] - } - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -namespace eval modpod::system { - #*** !doctools - #[subsection {Namespace modpod::system}] - #[para] Internal functions that are not part of the API - - #deflate,store only supported - proc make_mountable_zip {zipfile outfile mount_stub} { - set in [open $zipfile r] - fconfigure $in -encoding iso8859-1 -translation binary - set out [open $outfile w+] - fconfigure $out -encoding iso8859-1 -translation binary - puts -nonewline $out $mount_stub - set offset [tell $out] - lappend report "sfx stub size: $offset" - fcopy $in $out - - close $in - set size [tell $out] - #Now seek in $out to find the end of directory signature: - #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text - if {$size < 65559} { - set seek 0 - } else { - set seek [expr {$size - 65559}] - } - seek $out $seek - set data [read $out] - set start_of_end [string last "\x50\x4b\x05\x06" $data] - #set start_of_end [expr {$start_of_end + $seek}] - incr start_of_end $seek - - lappend report "START-OF-END: $start_of_end ([expr {$start_of_end - $size}]) [string length $data]" - - seek $out $start_of_end - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - lappend report "End of central directory: [array get eocd]" - seek $out [expr {$start_of_end+16}] - - #adjust offset of start of central directory by the length of our sfx stub - puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $offset}]] - flush $out - - seek $out $start_of_end - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - # 0x06054b50 - end of central dir signature - puts stderr "$end_of_ctrl_dir" - puts stderr "comment_len: $eocd(comment_len)" - puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" - lappend report "New dir offset: $eocd(diroffset)" - lappend report "Adjusting $eocd(totalnum) zip file items." - catch { - punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies - } - - seek $out $eocd(diroffset) - for {set i 0} {$i <$eocd(totalnum)} {incr i} { - set current_file [tell $out] - set fileheader [read $out 46] - puts -------------- - puts [ansistring VIEW -lf 1 $fileheader] - puts -------------- - #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - - binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - set ::last_header $fileheader - - puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" - puts "ver: $x(version)" - puts "method: $x(method)" - - #33639248 dec = 0x02014b50 - central file header signature - if { $x(sig) != 33639248 } { - error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" - } - - foreach size $x(lengths) var {filename extrafield comment} { - if { $size > 0 } { - set x($var) [read $out $size] - } else { - set x($var) "" - } - } - set next_file [tell $out] - lappend report "file $i: $x(offset) $x(sizes) $x(filename)" - - seek $out [expr {$current_file+42}] - puts -nonewline $out [binary format i [expr {$x(offset)+$offset}]] - - #verify: - flush $out - seek $out $current_file - set fileheader [read $out 46] - lappend report "old $x(offset) + $offset" - binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - lappend report "new $x(offset)" - - seek $out $next_file - } - close $out - #pdict/showdict reuire punk & textlib - ie lots of dependencies - #don't fall over just because of that - catch { - punk::lib::showdict -roottype list -chan stderr $report - } - #puts [join $report \n] - return - } - - proc connect_if_not {{podpath ""}} { - upvar ::modpod::connected connected - set podpath [::modpod::system::normalize $podpath] - set docon 0 - if {![llength $connected(to)]} { - if {![string length $podpath]} { - error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" - } else { - set docon 1 - } - } else { - if {![string length $podpath]} { - set podpath [lindex $connected(to) end] - puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" - } else { - if {$podpath ni $connected(to)} { - set docon 1 - } - } - } - if {$docon} { - if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { - error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" - } else { - return $podpath - } - } - #we were already connected - return $podpath - } - - proc myversion {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" - } - set fname [file tail [file rootname [file normalize $script]]] - set scriptdir [file dirname $script] - - if {![string match "#modpod-*" $fname]} { - lassign [lrange [split $fname -] end-1 end] _pkgname version - } else { - lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version - if {![string length $version]} { - #try again on the name of the containing folder - lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version - #todo - proper walk up the directory tree - if {![string length $version]} { - #try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) - lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version - } - } - } - - #tarjar::Log debug "'myversion' determined version for [info script]: $version" - return $version - } - - proc myname {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" - } - return $connected(fullpackage,$script) - } - proc myfullname {} { - upvar ::modpod::connected connected - set script [info script] - #set script [::tarjar::normalize $script] - set script [file normalize $script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" - } - return $::tarjar::connected(fullpackage,$script) - } - proc normalize {path} { - #newer versions of Tcl don't do tilde sub - - #Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) - # we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. - set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. - set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after - set path [file normalize $path] - #set path [string tolower $path] ;#must do this after file normalize - return [string map [list $matilda ~] $path] ;#get our tildes back. -} -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide modpod [namespace eval modpod { - variable pkg modpod - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.2.tm similarity index 95% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.1.tm rename to src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.2.tm index afa3be2a..aa27ebce 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.1.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.2.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application modpod 0.1.1 +# Application modpod 0.1.2 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.1] +#[manpage_begin modpod_module_modpod 0 0.1.2] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[moddesc {-}] [comment {-- Description at end of page heading --}] @@ -135,9 +135,10 @@ namespace eval modpod { proc connect {args} { puts stderr "modpod::connect--->>$args" set argd [punk::args::get_dict { + @id -id ::modpod::connect -type -default "" - *values -min 1 -max 1 - path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" + @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 @@ -329,14 +330,16 @@ 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 { - -offsettype -default "file" -choices {archive file} -help "Whether zip offsets are relative to start of file or start of zip-data within the file. - 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, - but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) - info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. - -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" - *values -min 2 -max 2 - zipfile -type path -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" - outfile -type path -minlen 1 -help "path to output file. Name should be of the form packagename-version.tm" + @id -id ::modpod::lib::make_zip_modpod + -offsettype -default "archive" -choices {archive file} -help\ + "Whether zip offsets are relative to start of file or start of zip-data within the file. + 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, + but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) + info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. + -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" + @values -min 2 -max 2 + zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" + outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" } $args] set zipfile [dict get $argd values zipfile] set outfile [dict get $argd values outfile] @@ -468,14 +471,14 @@ namespace eval modpod::system { #deflate,store only supported #zipfile here is plain zip - no script/exe prefix part. - proc make_mountable_zip {zipfile outfile mount_stub {offsettype "file"}} { + proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { set inzip [open $zipfile r] fconfigure $inzip -encoding iso8859-1 -translation binary set out [open $outfile w+] fconfigure $out -encoding iso8859-1 -translation binary puts -nonewline $out $mount_stub set stuboffset [tell $out] - lappend report "sfx stub size: $stuboffset" + lappend report "stub size: $stuboffset" fcopy $inzip $out close $inzip @@ -486,7 +489,9 @@ namespace eval modpod::system { 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 'zipfs mkimg' as at 2024-10 + #not editable by 7z,nanazip,peazip + #we aren't adding any new files/folders so we can edit the offsets in place #Now seek in $out to find the end of directory signature: @@ -688,7 +693,7 @@ namespace eval modpod::system { package provide modpod [namespace eval modpod { variable pkg modpod variable version - set version 0.1.1 + set version 0.1.2 }] return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/natsort-0.1.1.6.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/natsort-0.1.1.6.tm index 1d91b53f..7f7c33cd 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/natsort-0.1.1.6.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/natsort-0.1.1.6.tm @@ -5,8 +5,9 @@ package require flagfilter namespace import ::flagfilter::check_flags namespace eval natsort { + #REVIEW - determine and document the purpose of scriptdir being added to tm path proc scriptdir {} { - set possibly_linked_script [file dirname [file normalize [file join [info script] ...]]] + set possibly_linked_script [file dirname [file normalize [file join [info script] __dummy__]]] if {[file isdirectory $possibly_linked_script]} { return $possibly_linked_script } else { @@ -14,7 +15,11 @@ namespace eval natsort { } } if {![interp issafe]} { - tcl::tm::add [scriptdir] + set sdir [scriptdir] + #puts stderr "natsort tcl::tm::add $sdir" + if {$sdir ni [tcl::tm::list]} { + catch {tcl::tm::add $sdir} + } } } @@ -36,6 +41,7 @@ namespace eval natsort { } else { puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be one of '$levels' or 'exit '" } + flush stderr if {$::tcl_interactive} { #may not always be desirable - but assumed to be more useful not to exit despite request, to aid in debugging if {[string tolower $type] eq "exit"} { @@ -43,6 +49,7 @@ namespace eval natsort { if {![string is digit -strict $code]} { puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be: 'exit '" } + flush stderr } return -code error $msg } else { @@ -1422,6 +1429,9 @@ namespace eval natsort { proc called_directly_namematch {} { global argv0 + if {[info script] eq ""} { + return 0 + } #see https://wiki.tcl-lang.org/page/main+script #trailing ... let's us resolve symlinks in last component of the path (could be something else like ___ but ... seems unlikely to collide with anything in the filesystem) if {[info exists argv0] @@ -1440,12 +1450,18 @@ namespace eval natsort { #Review issues around comparing names vs using inodes (esp with respect to samba shares) proc called_directly_inodematch {} { global argv0 + if {[info exists argv0] - && [file exists [info script]] && [file exists $argv0]} { + && [file exists [info script]] && [file exists $argv0]} { file stat $argv0 argv0Info file stat [info script] scriptInfo - expr {$argv0Info(dev) == $scriptInfo(dev) - && $argv0Info(ino) == $scriptInfo(ino)} + if {$argv0Info(ino) == 0 || $scriptInfo(ino) == 0 || $argv0Info(dev) == 0 || $scriptInfo(dev) == 0} { + #vfs? + #e.g //zipfs:/ + return 0 + } + return [expr {$argv0Info(dev) == $scriptInfo(dev) + && $argv0Info(ino) == $scriptInfo(ino)}] } else { return 0 } @@ -1460,6 +1476,11 @@ namespace eval natsort { #-- choose a policy and leave the others commented. #set is_called_directly $is_namematch #set is_called_directly $is_inodematch + + #puts "NATSORT: called_directly_namematch - $is_namematch" + #puts "NATSORT: called_directly_inodematch - $is_inodematch" + #flush stdout + set is_called_directly [expr {$is_namematch || $is_inodematch}] #set is_called_directly [expr {$is_namematch && $is_inodematch}] ### @@ -1921,6 +1942,8 @@ namespace eval natsort { #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {{-cmd -default help} {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {ls {ls lsdir -default "\uFFFF"}} -values $::argv ] + puts stderr "natsort directcall exit" + flush stderr exit 0 if {$::argc} { 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.5.tm index 143794fb..9363fb6d 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.5.tm @@ -163,22 +163,23 @@ proc overtype::string_columns {text} { tcl::namespace::eval overtype::priv { } -#could return larger than colwidth +#could return larger than renderwidth proc _get_row_append_column {row} { + #obsolete? upvar outputlines outputlines set idx [expr {$row -1}] if {$row <= 1 || $row > [llength $outputlines]} { return 1 } else { - upvar opt_overflow opt_overflow - upvar colwidth colwidth + upvar opt_expand_right expand_right + upvar renderwidth renderwidth set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] set endpos [expr {$existinglen +1}] - if {$opt_overflow} { + if {$expand_right} { return $endpos } else { - if {$endpos > $colwidth} { - return $colwidth + 1 + if {$endpos > $renderwidth} { + return $renderwidth + 1 } else { return $endpos } @@ -204,40 +205,80 @@ tcl::namespace::eval overtype { proc renderspace {args} { #*** !doctools #[call [fun overtype::renderspace] [arg args] ] - #[para] usage: ?-transparent [lb]0|1[rb]? ?-overflow [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext + #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext # @c overtype starting at left (overstrike) # @c can/should we use something like this?: 'format "%-*s" $len $overtext variable default_ellipsis_horizontal if {[llength $args] < 2} { - error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + set optargs [lrange $args 0 end-2] + if {[llength $optargs] % 2 == 0} { + set overblock [lindex $args end] + set underblock [lindex $args end-1] + #lassign [lrange $args end-1 end] underblock overblock + set argsflags [lrange $args 0 end-2] + } else { + set optargs [lrange $args 0 end-1] + if {[llength $optargs] %2 == 0} { + set overblock [lindex $args end] + set underblock "" + set argsflags [lrange $args 0 end-1] + } else { + error "renderspace expects opt-val pairs followed by: or just " + } } - lassign [lrange $args end-1 end] underblock overblock set opts [tcl::dict::create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ + -bias ignored\ + -width \uFFEF\ + -height \uFFEF\ -startcolumn 1\ - -wrap 0\ - -ellipsis 0\ + -ellipsis 0\ -ellipsistext $default_ellipsis_horizontal\ -ellipsiswhitespace 0\ - -overflow 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -looplimit \uFFEF\ + -expand_right 0\ + -appendlines 1\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -experimental 0\ + -cp437 0\ + -looplimit \uFFEF\ + -crm_mode 0\ + -reverse_mode 0\ + -insert_mode 0\ + -wrap 0\ + -info 0\ + -console {stdin stdout stderr}\ ] + #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. + # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) + # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. + # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. + # - further implication is that if expand_right grows the virtual renderspace terminal width - + # then some sort of reflow/rerender needs to be done for preceeding lines? + # possibly not - as expand_right is distinct from a normal terminal-width change event, + # expand_right being primarily to support other operations such as textblock::table + + #todo - viewport width/height as separate concept to terminal width/height? #-ellipsis args not used if -wrap is true - set argsflags [lrange $args 0 end-2] foreach {k v} $argsflags { switch -- $k { - -looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines - -transparent - -exposed1 - -exposed2 - -experimental { + -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace + - -transparent - -exposed1 - -exposed2 - -experimental + - -expand_right - -appendlines + - -reverse_mode - -crm_mode - -insert_mode + - -cp437 + - -info - -console { tcl::dict::set opts $k $v } + -wrap - -autowrap_mode { + #temp alias -autowrap_mode for consistency with renderline + #todo - + tcl::dict::set opts -wrap $v + } default { error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" } @@ -245,11 +286,8 @@ tcl::namespace::eval overtype { } #set opts [tcl::dict::merge $defaults $argsflags] # -- --- --- --- --- --- - set opt_overflow [tcl::dict::get $opts -overflow] - ##### - # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. - set opt_wrap [tcl::dict::get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) - ##### + #review - expand_left for RTL text? + set opt_expand_right [tcl::dict::get $opts -expand_right] #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. set opt_width [tcl::dict::get $opts -width] set opt_height [tcl::dict::get $opts -height] @@ -261,43 +299,37 @@ tcl::namespace::eval overtype { set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo # -- --- --- --- --- --- + set opt_crm_mode [tcl::dict::get $opts -crm_mode] + set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] + set opt_insert_mode [tcl::dict::get $opts -insert_mode] + ##### + # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. + set opt_autowrap_mode [tcl::dict::get $opts -wrap] + #??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) + ##### + # -- --- --- --- --- --- + set opt_cp437 [tcl::dict::get $opts -cp437] + set opt_info [tcl::dict::get $opts -info] + + # ---------------------------- # -experimental dev flag to set flags etc # ---------------------------- set data_mode 0 - set test_mode 1 - set info_mode 0 set edit_mode 0 set opt_experimental [tcl::dict::get $opts -experimental] foreach o $opt_experimental { switch -- $o { - test_mode { - set test_mode 1 - set info_mode 1 - } - old_mode { - set test_mode 0 - set info_mode 1 - } data_mode { set data_mode 1 } - info_mode { - set info_mode 1 - } edit_mode { set edit_mode 1 } } } - set test_mode 1 ;#try to eliminate # ---------------------------- - - #modes - set insert_mode 0 ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l - set autowrap_mode $opt_wrap - set reverse_mode 0 set underblock [tcl::string::map {\r\n \n} $underblock] @@ -307,33 +339,49 @@ tcl::namespace::eval overtype { #set underlines [split $underblock \n] #underblock is a 'rendered' block - so width height make sense - #colwidth & colheight were originally named with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. - #The naming is now confusing. It should be something like renderwidth renderheight ?? review + #only non-cursor affecting and non-width occupying ANSI codes should be present. + #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already + #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { - lassign [blocksize $underblock] _w colwidth _h colheight + lassign [blocksize $underblock] _w renderwidth _h renderheight if {$opt_width ne "\uFFEF"} { - set colwidth $opt_width + set renderwidth $opt_width } if {$opt_height ne "\uFFEF"} { - set colheight $opt_height + set renderheight $opt_height } } else { - set colwidth $opt_width - set colheight $opt_height + set renderwidth $opt_width + set renderheight $opt_height } + #initial state for renderspace 'terminal' reset + set initial_state [dict create\ + renderwidth $renderwidth\ + renderheight $renderheight\ + crm_mode $opt_crm_mode\ + reverse_mode $opt_reverse_mode\ + insert_mode $opt_insert_mode\ + autowrap_mode $opt_autowrap_mode\ + cp437 $opt_cp437\ + ] + #modes + #e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l + #opt_startcolumn ?? - DECSLRM ? + set vtstate $initial_state # -- --- --- --- #REVIEW - do we need ansi resets in the underblock? if {$underblock eq ""} { - set underlines [lrepeat $colheight ""] + set underlines [lrepeat $renderheight ""] } else { + set underblock [textblock::join_basic -- $underblock] ;#ensure properly rendered - ansi per-line resets & replays set underlines [split $underblock \n] } #if {$underblock eq ""} { # set blank "\x1b\[0m\x1b\[0m" # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $colheight $blank] + # set underlines [lrepeat $renderheight $blank] #} else { # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW # set underlines [lines_as_list -ansiresets 1 $underblock] @@ -341,7 +389,7 @@ tcl::namespace::eval overtype { # -- --- --- --- #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. - #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output colwidth + #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. #(in cases where there are interline moves or cursor jumps anyway) #This works - but doesn't seem efficient. @@ -356,60 +404,67 @@ tcl::namespace::eval overtype { set looplimit [expr {[tcl::string::length $overblock] + 10}] } - if {!$test_mode} { - set inputchunks [split $overblock \n] - } else { - set scheme 3 - switch -- $scheme { - 0 { - #one big chunk - set inputchunks [list $overblock] + #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height + #lassign [blocksize $overblock] _w overblock_width _h overblock_height + + set scheme 4 + switch -- $scheme { + 0 { + #one big chunk + set inputchunks [list $overblock] + } + 1 { + set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 2 { + + #split into lines if possible first - then into plaintext/ansi-sequence chunks ? + set inputchunks [list ""] ;#put an empty plaintext split in for starters + set i 1 + set lines [split $overblock \n] + foreach ln $lines { + if {$i < [llength $lines]} { + append ln \n + } + set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? + set lastpt [lindex $inputchunks end] + lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] + lappend inputchunks {*}[lrange $sequence_split 1 end] + incr i } - 1 { - set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 3 { + #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice + set lflines [list] + set inputchunks [split $overblock \n] + foreach ln $inputchunks { + append ln \n + lappend lflines $ln } - 2 { - - #split into lines if possible first - then into plaintext/ansi-sequence chunks ? - set inputchunks [list ""] ;#put an empty plaintext split in for starters - set i 1 - set lines [split $overblock \n] - foreach ln $lines { - if {$i < [llength $lines]} { - append ln \n - } - set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? - set lastpt [lindex $inputchunks end] - lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] - lappend inputchunks {*}[lrange $sequence_split 1 end] - incr i - } + if {[llength $lflines]} { + lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] } - 3 { - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice - set lflines [list] - set inputchunks [split $overblock \n] - foreach ln $inputchunks { - append ln \n - lappend lflines $ln - } - if {[llength $lflines]} { - lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] - } - set inputchunks $lflines[unset lflines] + #set inputchunks $lflines[unset lflines] + set inputchunks [lindex [list $lflines [unset lflines]] 0] + } + 4 { + set inputchunks [list] + foreach ln [split $overblock \n] { + lappend inputchunks $ln\n + } + if {[llength $inputchunks]} { + lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] } } } - #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height - #lassign [blocksize $overblock] _w overblock_width _h overblock_height set replay_codes_underlay [tcl::dict::create 1 ""] #lappend replay_codes_overlay "" - set replay_codes_overlay "" + set replay_codes_overlay "[punk::ansi::a]" set unapplied "" set cursor_saved_position [tcl::dict::create] set cursor_saved_attributes "" @@ -420,11 +475,11 @@ tcl::namespace::eval overtype { #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext set row 1 - if {$data_mode} { - set col [_get_row_append_column $row] - } else { + #if {$data_mode} { + # set col [_get_row_append_column $row] + #} else { set col $opt_startcolumn - } + #} set instruction_stats [tcl::dict::create] @@ -446,47 +501,87 @@ tcl::namespace::eval overtype { #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set overtext $replay_codes_overlay$overtext if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::string::cat [tcl::dict::get $replay_codes_underlay $row] $undertext] + set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set LASTCALL [list -info 1 -insert_mode $insert_mode -autowrap_mode $autowrap_mode -transparent $opt_transparent -width $colwidth -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -cursor_column $col -cursor_row $row $undertext $overtext] - set rinfo [renderline -experimental $opt_experimental\ - -info 1\ - -insert_mode $insert_mode\ - -cursor_restore_attributes $cursor_saved_attributes\ - -autowrap_mode $autowrap_mode\ - -transparent $opt_transparent\ - -width $colwidth\ - -exposed1 $opt_exposed1\ - -exposed2 $opt_exposed2\ - -overflow $opt_overflow\ - -cursor_column $col\ - -cursor_row $row\ - $undertext\ - $overtext\ - ] - set instruction [tcl::dict::get $rinfo instruction] - set insert_mode [tcl::dict::get $rinfo insert_mode] - set autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# - #set reverse_mode [tcl::dict::get $rinfo reverse_mode];#how to support in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] - set unapplied [tcl::dict::get $rinfo unapplied] - set unapplied_list [tcl::dict::get $rinfo unapplied_list] - set post_render_col [tcl::dict::get $rinfo cursor_column] - set post_render_row [tcl::dict::get $rinfo cursor_row] - set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] - set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes] - set visualwidth [tcl::dict::get $rinfo visualwidth] - set insert_lines_above [tcl::dict::get $rinfo insert_lines_above] - set insert_lines_below [tcl::dict::get $rinfo insert_lines_below] - tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay] + set renderopts [list -experimental $opt_experimental\ + -cp437 $opt_cp437\ + -info 1\ + -crm_mode [tcl::dict::get $vtstate crm_mode]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -reverse_mode [tcl::dict::get $vtstate reverse_mode]\ + -cursor_restore_attributes $cursor_saved_attributes\ + -transparent $opt_transparent\ + -width [tcl::dict::get $vtstate renderwidth]\ + -exposed1 $opt_exposed1\ + -exposed2 $opt_exposed2\ + -expand_right $opt_expand_right\ + -cursor_column $col\ + -cursor_row $row\ + ] + set rinfo [renderline {*}$renderopts $undertext $overtext] + + set instruction [tcl::dict::get $rinfo instruction] + tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] + tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode] + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# + tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode] + #how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? + # - review - the answer is probably that we don't need to - it is set/reset only during application of overtext + + #Note carefully the difference betw overflow_right and unapplied. + #overflow_right may need to be included in next run before the unapplied data + #overflow_right most commonly has data when in insert_mode + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] + set unapplied [tcl::dict::get $rinfo unapplied] + set unapplied_list [tcl::dict::get $rinfo unapplied_list] + set post_render_col [tcl::dict::get $rinfo cursor_column] + set post_render_row [tcl::dict::get $rinfo cursor_row] + set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] + set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes] + set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line + set insert_lines_above [tcl::dict::get $rinfo insert_lines_above] + set insert_lines_below [tcl::dict::get $rinfo insert_lines_below] + tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay] + #lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + if {0 && [tcl::dict::get $vtstate reverse_mode]} { + #test branch - todo - prune + puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" + #review + #JMN3 + set existing_reverse_state 0 + #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence + #e.g \x1b\[0;31;7m has a reset,colour red and reverse + set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] + set codestate_reverse [dict get $codeinfo codestate reverse] + switch -- $codestate_reverse { + 7 { + set existing_reverse_state 1 + } + 27 { + set existing_reverse_state 0 + } + "" { + } + } + if {$existing_reverse_state == 0} { + set rflip [a+ reverse] + } else { + #reverse of reverse + set rflip [a+ noreverse] + } + #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] + puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" + } @@ -513,31 +608,29 @@ tcl::namespace::eval overtype { #todo - handle potential insertion mode as above for cursor restore? #keeping separate branches for debugging - review and merge as appropriate when stable - tcl::dict::incr instruction_stats $instruction - switch -- $instruction { + set instruction_type [lindex $instruction 0] ;#some instructions have params + tcl::dict::incr instruction_stats $instruction_type + switch -- $instruction_type { + reset { + #reset the 'renderspace terminal' (not underlying terminal) + set row 1 + set col 1 + set vtstate [tcl::dict::merge $vtstate $initial_state] + #todo - clear screen + } {} { - if {$test_mode == 0} { - incr row - if {$data_mode} { - set col [_get_row_append_column $row] - if {$col > $colwidth} { - - } - } else { - set col 1 + #end of supplied line input + #lf included in data + set row $post_render_row + set col $post_render_col + if {![llength $unapplied_list]} { + if {$overflow_right ne ""} { + incr row } } else { - #lf included in data - set row $post_render_row - set col $post_render_col - - #set col 1 - #if {$post_render_row != $renderedrow} { - # set col 1 - #} else { - # set col $post_render_col - #} + puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" } + set col $opt_startcolumn } up { @@ -563,10 +656,10 @@ tcl::namespace::eval overtype { #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) set existingdata [lindex $outputlines [expr {$post_render_row -1}]] set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { + if {$lastdatacol < $renderwidth} { set col [expr {$lastdatacol+1}] } else { - set col $colwidth + set col $renderwidth } } @@ -601,10 +694,10 @@ tcl::namespace::eval overtype { } set existingdata [lindex $outputlines [expr {$post_render_row -1}]] set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { + if {$lastdatacol < $renderwidth} { set col [expr {$lastdatacol+1}] } else { - set col $colwidth + set col $renderwidth } } @@ -640,10 +733,18 @@ tcl::namespace::eval overtype { puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - set sub_info [overtype::renderline -info 1 -width $colwidth -insert_mode $insert_mode -autowrap_mode $autowrap_mode -overflow [tcl::dict::get $opts -overflow] "" $overflow_right] - set foldline [tcl::dict::get $sub_info result] - set insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed.. - set autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. + set sub_info [overtype::renderline\ + -info 1\ + -width [tcl::dict::get $vtstate renderwidth]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -expand_right [tcl::dict::get $opts -expand_right]\ + ""\ + $overflow_right\ + ] + set foldline [tcl::dict::get $sub_info result] + tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. linsert outputlines $renderedrow $foldline #review - row & col set by restore - but not if there was no save.. } @@ -670,8 +771,55 @@ tcl::namespace::eval overtype { set col $post_render_col #overflow + unapplied? } + clear_and_move { + #e.g 2J + if {$post_render_row > [llength $outputlines]} { + set row [llength $outputlines] + } else { + set row $post_render_row + } + set col $post_render_col + set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant + set clearedlines [list] + foreach ln $outputlines { + lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m + if 0 { + + set lineparts [punk::ansi::ta::split_codes $ln] + set numcells 0 + foreach {pt _code} $lineparts { + if {$pt ne ""} { + foreach grapheme [punk::char::grapheme_split $pt] { + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + incr numcells 1 + } + default { + if {$grapheme eq "\u0000"} { + incr numcells 1 + } else { + incr numcells [grapheme_width_cached $grapheme] + } + } + } + + } + } + } + #replays/resets each line + lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m + } + } + set outputlines $clearedlines + #todo - determine background/default to be in effect - DECECM ? + puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" + #lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0] + + } lf_start { - #raw newlines - must be test_mode + #raw newlines # ---------------------- #test with fruit.ans #test - treating as newline below... @@ -687,48 +835,79 @@ tcl::namespace::eval overtype { } lf_mid { - if 0 { - #set rhswidth [punk::ansi::printing_length $overflow_right] - #only show debug when we have overflow? - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - - set rhs "" - if {$overflow_right ne ""} { - set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $overflow_right]] - set rhs [textblock::frame -title overflow_right $rhs] - } - puts [textblock::join $lhs " $post_render_col " $rhs] - } - - if {!$test_mode} { - #rendered - append rendered $overflow_right - #set replay_codes_overlay "" + set edit_mode 0 + if {$edit_mode} { + set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] set overflow_right "" - - - set row $renderedrow - + set unapplied "" + set row $post_render_row + #set col $post_render_col set col $opt_startcolumn - incr row - #only add newline if we're at the bottom if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } } else { - set edit_mode 0 - if {$edit_mode} { - set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - set overflow_right "" - set unapplied "" + if 1 { + if {$overflow_right ne ""} { + if {$opt_expand_right} { + append rendered $overflow_right + set overflow_right "" + } else { + #review - we should really make renderline do the work...? + set overflow_width [punk::ansi::printing_length $overflow_right] + if {$visualwidth + $overflow_width <= $renderwidth} { + append rendered $overflow_right + set overflow_right "" + } else { + if {[tcl::dict::get $vtstate autowrap_mode]} { + set outputlines [linsert $outputlines $renderedrow $overflow_right] + set overflow_right "" + set row [expr {$renderedrow + 2}] + } else { + set overflow_right "" ;#abandon + } + + if {0 && $visualwidth < $renderwidth} { + puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" + error "incomplete - abandon?" + set overflowparts [punk::ansi::ta::split_codes $overflow_right] + set remaining_overflow $overflowparts + set filled 0 + foreach {pt code} $overflowparts { + lpop remaining_overflow 0 + if {$pt ne ""} { + set graphemes [punk::char::grapheme_split $pt] + set add "" + set addlen $visualwidth + foreach g $graphemes { + set w [overtype::grapheme_width_cached $g] + if {$addlen + $w <= $renderwidth} { + append add $g + incr addlen $w + } else { + set filled 1 + break + } + } + append rendered $add + } + if {!$filled} { + lpop remaining_overflow 0 ;#pop code + } + } + set overflow_right [join $remaining_overflow ""] + } + } + } + } set row $post_render_row - #set col $post_render_col set col $opt_startcolumn if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } } else { + #old version - known to work with various ansi graphics - e.g fruit.ans + # - but fails to limit lines to renderwidth when expand_right == 0 append rendered $overflow_right set overflow_right "" set row $post_render_row @@ -740,18 +919,20 @@ tcl::namespace::eval overtype { } } lf_overflow { - #linefeed after colwidth e.g at column 81 for an 80 col width + #linefeed after renderwidth e.g at column 81 for an 80 col width #we may also have other control sequences that came after col 80 e.g cursor save if 0 { - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - set rhs "" + set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] + set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] + set rhs "" - #assertion - there should be no overflow.. - puts $lhs + #assertion - there should be no overflow.. + puts $lhs + } + if {![tcl::dict::get $vtstate insert_mode]} { + assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode } - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right set row $post_render_row #set row $renderedrow @@ -787,38 +968,28 @@ tcl::namespace::eval overtype { set row $post_render_row set col $post_render_col if {$insert_lines_below == 1} { - if {$test_mode == 0} { - set row $renderedrow - set outputlines [linsert $outputlines [expr {$renderedrow }] {*}[lrepeat $insert_lines_below ""]] ;#note - linsert can add to end too - incr row $insert_lines_below - set col $opt_startcolumn - } else { - #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] - #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] - #set rhs "" - #if {$overflow_right ne ""} { - # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] - # set rhs [textblock::frame -title overflow_right $rhs] - #} - #puts [textblock::join $lhs $rhs] - - #rendered - append rendered $overflow_right - # - - - set overflow_right "" - set row $renderedrow - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat $insert_lines_below ""] - } - incr row $insert_lines_below - set col $opt_startcolumn + #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] + #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] + #set rhs "" + #if {$overflow_right ne ""} { + # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] + # set rhs [textblock::frame -title overflow_right $rhs] + #} + #puts [textblock::join $lhs $rhs] + #rendered + append rendered $overflow_right + # + set overflow_right "" + set row $renderedrow + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat $insert_lines_below ""] } + incr row $insert_lines_below + set col $opt_startcolumn } } else { set row $post_render_row @@ -833,10 +1004,10 @@ tcl::namespace::eval overtype { } else { set existingdata [lindex $outputlines [expr {$post_render_row -1}]] set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { + if {$lastdatacol < $renderwidth} { set col [expr {$lastdatacol+1}] } else { - set col $colwidth + set col $renderwidth } } } @@ -845,12 +1016,12 @@ tcl::namespace::eval overtype { #doesn't seem to be used by fruit.ans testfile #used by dzds.ans #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO - set c $colwidth + set c $renderwidth set r $post_render_row - if {$post_render_col > $colwidth} { + if {$post_render_col > $renderwidth} { set i $c while {$i <= $post_render_col} { - if {$c == $colwidth+1} { + if {$c == $renderwidth+1} { incr r if {$opt_appendlines} { if {$r < [llength $outputlines]} { @@ -874,7 +1045,7 @@ tcl::namespace::eval overtype { set col $c } wrapmovebackward { - set c $colwidth + set c $renderwidth set r $post_render_row if {$post_render_col < 1} { set c 1 @@ -883,7 +1054,7 @@ tcl::namespace::eval overtype { if {$c == 0} { if {$r > 1} { incr r -1 - set c $colwidth + set c $renderwidth } else { #leave r at 1 set c 1 #testfile besthpav.ans first line top left border alignment @@ -906,11 +1077,10 @@ tcl::namespace::eval overtype { #normal single-width grapheme overflow #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" set row $post_render_row ;#renderline will not advance row when reporting overflow char - if {$autowrap_mode} { + if {[tcl::dict::get $vtstate autowrap_mode]} { incr row set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? } else { - #this works for test_mode (which should become the default) - but could give a bad result otherwise - review - add tests fix. set col $post_render_col #set unapplied "" ;#this seems wrong? #set unapplied [tcl::string::range $unapplied 1 end] @@ -940,8 +1110,8 @@ tcl::namespace::eval overtype { #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc - if {$autowrap_mode} { - if {$colwidth < 2} { + if {[tcl::dict::get $vtstate autowrap_mode]} { + if {$renderwidth < 2} { #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character set idx 0 set triggering_grapheme_index -1 @@ -960,7 +1130,7 @@ tcl::namespace::eval overtype { } else { set overflow_handled 1 #handled by dropping entire overflow if any - if {$colwidth < 2} { + if {$renderwidth < 2} { set idx 0 set triggering_grapheme_index -1 foreach u $unapplied_list { @@ -981,6 +1151,14 @@ tcl::namespace::eval overtype { set row $post_render_row set col $post_render_col } + set_window_title { + set newtitle [lindex $instruction 1] + puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'" + # + } + reset_colour_palette { + puts stderr "overtype::renderspace instruction '$instruction' unimplemented" + } default { puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" } @@ -988,7 +1166,7 @@ tcl::namespace::eval overtype { } - if {!$opt_overflow && !$autowrap_mode} { + if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { #not allowed to overflow column or wrap therefore we get overflow data to truncate if {[tcl::dict::get $opts -ellipsis]} { set show_ellipsis 1 @@ -1066,11 +1244,10 @@ tcl::namespace::eval overtype { set debugmsg "" append debugmsg "${Y}${sep_header}${RST}" \n append debugmsg "looplimit $looplimit reached\n" - append debugmsg "test_mode:$test_mode\n" append debugmsg "data_mode:$data_mode\n" append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $LASTCALL -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $LASTCALL -cursor_column]\n" + append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" + append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" tcl::dict::for {k v} $rinfo { append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n } @@ -1087,11 +1264,22 @@ tcl::namespace::eval overtype { } set result [join $outputlines \n] - if {$info_mode} { + if {!$opt_info} { + return $result + } else { #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? #append result \n$instruction_stats\n + set inforesult [dict create\ + result $result\ + last_instruction $instruction\ + instruction_stats $instruction_stats\ + ] + if {$opt_info == 2} { + return [pdict -channel none inforesult] + } else { + return $inforesult + } } - return $result } #todo - left-right ellipsis ? @@ -1141,12 +1329,11 @@ tcl::namespace::eval overtype { set overblock [tcl::string::map {\r\n \n} $overblock] set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight + #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] + lassign [blocksize $underblock] _w renderwidth _h renderheight set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {$colwidth - $overblock_width}] + set under_exposed_max [expr {$renderwidth - $overblock_width}] if {$under_exposed_max > 0} { #background block is wider if {$under_exposed_max % 2 == 0} { @@ -1176,19 +1363,20 @@ tcl::namespace::eval overtype { foreach undertext $underlines overtext $overlines { set overtext_datalen [punk::ansi::printing_length $overtext] set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] set undertext "$undertext[string repeat { } $udiff]" } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext - set overflowlength [expr {$overtext_datalen - $colwidth}] + set overflowlength [expr {$overtext_datalen - $renderwidth}] #review - right-to-left langs should elide on left! - extra option required if {$overflowlength > 0} { #overlay line wider or equal - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + #review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end? + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] set rendered [tcl::dict::get $rinfo result] set overflow_right [tcl::dict::get $rinfo overflow_right] set unapplied [tcl::dict::get $rinfo unapplied] @@ -1196,8 +1384,8 @@ tcl::namespace::eval overtype { #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified if {![tcl::dict::get $opts -overflow]} { - #lappend outputlines [tcl::string::range $overtext 0 [expr {$colwidth - 1}]] - #set overtext [tcl::string::range $overtext 0 $colwidth-1 ] + #lappend outputlines [tcl::string::range $overtext 0 [expr {$renderwidth - 1}]] + #set overtext [tcl::string::range $overtext 0 $renderwidth-1 ] if {$opt_ellipsis} { set show_ellipsis 1 if {!$opt_ellipsiswhitespace} { @@ -1286,12 +1474,11 @@ tcl::namespace::eval overtype { set overblock [tcl::string::map {\r\n \n} $overblock] set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight + lassign [blocksize $underblock] _w renderwidth _h renderheight set overlines [split $overblock \n] #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$colwidth - $overblock_width)}] + set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] set left_exposed $under_exposed_max @@ -1307,8 +1494,8 @@ tcl::namespace::eval overtype { foreach undertext $underlines overtext $overlines { set overtext_datalen [punk::ansi::printing_length $overtext] set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] #puts xxx append undertext [string repeat { } $udiff] } @@ -1333,13 +1520,20 @@ tcl::namespace::eval overtype { set startoffset 0 ;#negative? } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext - set overflowlength [expr {$overtext_datalen - $colwidth}] + set overflowlength [expr {$overtext_datalen - $renderwidth}] if {$overflowlength > 0} { #raw overtext wider than undertext column - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] + set rinfo [renderline\ + -info 1\ + -insert_mode 0\ + -transparent $opt_transparent\ + -exposed1 $opt_exposed1 -exposed2 $opt_exposed2\ + -overflow $opt_overflow\ + -startcolumn [expr {1 + $startoffset}]\ + $undertext $overtext] set replay_codes [tcl::dict::get $rinfo replay_codes] set rendered [tcl::dict::get $rinfo result] if {!$opt_overflow} { @@ -1353,7 +1547,7 @@ tcl::namespace::eval overtype { } } if {$show_ellipsis} { - set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] + set ellipsis $replay_codes$opt_ellipsistext #todo - overflow on left if allign = right?? set rendered [overtype::right $rendered $ellipsis] } @@ -1363,8 +1557,8 @@ tcl::namespace::eval overtype { } else { #padded overtext #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] lappend outputlines [tcl::dict::get $rinfo result] } set replay_codes [tcl::dict::get $rinfo replay_codes] @@ -1433,12 +1627,11 @@ tcl::namespace::eval overtype { set overblock [tcl::string::map {\r\n \n} $overblock] set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight + lassign [blocksize $underblock] _w renderwidth _h renderheight set overlines [split $overblock \n] #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$colwidth - $overblock_width)}] + set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] switch -- $opt_blockalign { left { @@ -1484,8 +1677,8 @@ tcl::namespace::eval overtype { foreach undertext $underlines overtext $overlines { set overtext_datalen [punk::ansi::printing_length $overtext] set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] #puts xxx append undertext [string repeat { } $udiff] } @@ -1510,13 +1703,13 @@ tcl::namespace::eval overtype { set startoffset 0 ;#negative? } - set undertext [tcl::string::cat $replay_codes_underlay $undertext] - set overtext [tcl::string::cat $replay_codes_overlay $overtext] + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext - set overflowlength [expr {$overtext_datalen - $colwidth}] + set overflowlength [expr {$overtext_datalen - $renderwidth}] if {$overflowlength > 0} { #raw overtext wider than undertext column - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] set replay_codes [tcl::dict::get $rinfo replay_codes] set rendered [tcl::dict::get $rinfo result] set overflow_right [tcl::dict::get $rinfo overflow_right] @@ -1564,8 +1757,9 @@ tcl::namespace::eval overtype { } else { #padded overtext #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + #Note - we still need expand_right here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" set overflow_right [tcl::dict::get $rinfo overflow_right] set unapplied [tcl::dict::get $rinfo unapplied] lappend outputlines [tcl::dict::get $rinfo result] @@ -1577,6 +1771,9 @@ tcl::namespace::eval overtype { return [join $outputlines \n] } + + variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. @@ -1586,7 +1783,8 @@ tcl::namespace::eval overtype { #-returnextra enables returning of overflow and length #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements - #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char) + #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char? + # This would probably be impractical to support for different fonts) #todo - review transparency issues with single/double width characters #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? proc renderline {args} { @@ -1608,11 +1806,16 @@ tcl::namespace::eval overtype { #[para] The main 3 are the result, overflow_right, and unapplied. #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. + #puts stderr "renderline '$args'" + variable optimise_ptruns + if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-overflow [1|0]? undertext overtext} + error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} } - lassign [lrange $args end-1 end] under over - if {[string first \n $under] >= 0} { + set under [lindex $args end-1] + set over [lindex $args end] + #lassign [lrange $args end-1 end] under over + if {[string last \n $under] >= 0} { error "overtype::renderline not allowed to contain newlines in undertext" } #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { @@ -1623,12 +1826,13 @@ tcl::namespace::eval overtype { set opts [tcl::dict::create\ -etabs 0\ -width \uFFEF\ - -overflow 0\ + -expand_right 0\ -transparent 0\ -startcolumn 1\ -cursor_column 1\ -cursor_row ""\ -insert_mode 1\ + -crm_mode 0\ -autowrap_mode 1\ -reverse_mode 0\ -info 0\ @@ -1643,13 +1847,15 @@ tcl::namespace::eval overtype { #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs - #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow + #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error set argsflags [lrange $args 0 end-2] tcl::dict::for {k v} $argsflags { switch -- $k { - -experimental - -cp437 - -width - -overflow - -transparent - -startcolumn - -cursor_column - -cursor_row - -insert_mode - -autowrap_mode - -reverse_mode - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { + -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row + - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode + - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { tcl::dict::set opts $k $v } default { @@ -1660,7 +1866,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- --- --- --- --- set opt_width [tcl::dict::get $opts -width] set opt_etabs [tcl::dict::get $opts -etabs] - set opt_overflow [tcl::dict::get $opts -overflow] + set opt_expand_right [tcl::dict::get $opts -expand_right] set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay set opt_row_context [tcl::dict::get $opts -cursor_row] @@ -1676,20 +1882,11 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- --- --- --- --- set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM + set opt_crm_mode [tcl::dict::get $opts -crm_mode];# CRM - show control character mode # -- --- --- --- --- --- --- --- --- --- --- --- set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] - set test_mode 0 set cp437_glyphs [tcl::dict::get $opts -cp437] - foreach e [tcl::dict::get $opts -experimental] { - switch -- $e { - test_mode { - set test_mode 1 - set cp437_glyphs 1 - } - } - } - set test_mode 1 ;#try to elminate set cp437_map [tcl::dict::create] if {$cp437_glyphs} { set cp437_map [set ::punk::ansi::cp437_map] @@ -1721,6 +1918,10 @@ tcl::namespace::eval overtype { set cursor_row $opt_row_context } + set insert_mode $opt_insert_mode ;#default 1 + set autowrap_mode $opt_autowrap_mode ;#default 1 + set crm_mode $opt_crm_mode ;#default 0 (Show Control Character mode) + set reverse_mode $opt_reverse_mode #----- # @@ -1768,72 +1969,123 @@ tcl::namespace::eval overtype { } set understacks [list] set understacks_gx [list] + set pm_list [list] set i_u -1 ;#underlay may legitimately be empty set undercols [list] set u_codestack [list] #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) - #set pt_underchars "" ;#for string_columns length calculation for overflow 0 truncation + #set pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation set remainder [list] ;#for returnextra foreach {pt code} $undermap { #pt = plain text #append pt_underchars $pt - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. - #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. - #todo - test decimal value instead, compare performance - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - set width 1 + if {$pt ne ""} { + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex + set re [tcl::string::cat {^[} \\U$hex {]+$}] + set is_ptrun [regexp $re $pt] + } + if {$is_ptrun} { + #switch -- $p1 { + # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + # set width 1 + # } + # default { + # if {$p1 eq "\u0000"} { + # #use null as empty cell representation - review + # #use of this will probably collide with some application at some point + # #consider an option to set the empty cell character + # set width 1 + # } else { + # set width [grapheme_width_cached $p1] ;# when zero??? + # } + # } + #} + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] + lappend undercols {*}[lrepeat $ptlen $p1] + } else { + incr i_u $ptlen ;#2nd col empty str - so same as above + set 2ptlen [expr {$ptlen * 2}] + lappend understacks {*}[lrepeat $2ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]] + lappend undercols {*}$l + unset l } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] - set grapheme $gvis + + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + set width 1 + } + default { + if {$grapheme eq "\u0000"} { + #use null as empty cell representation - review + #use of this will probably collide with some application at some point + #consider an option to set the empty cell character set width 1 + } else { + #zero width still acts as 1 below??? review what should happen + set width [grapheme_width_cached $grapheme] + #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length + #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI + #todo - default to off and add a flag (?) to enable this substitution + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. + set grapheme $gvis + set width 1 + } + } } } } + + #set width [grapheme_width_cached $grapheme] + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + + lappend undercols $grapheme + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + #but what about emoji combinations etc - can they be wider than 2? + #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + lappend undercols "" + } } - } - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" + } } - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #keep any remaining PMs in place if {$code ne ""} { set c1c2 [tcl::string::range $code 0 1] @@ -1841,6 +2093,8 @@ tcl::namespace::eval overtype { \x1b\[ 7CSI\ \x9b 8CSI\ \x1b\( 7GFX\ + \x1b^ 7PMX\ + \x1bX 7SOS\ ] $c1c2] 0 3];# leadernorm is 1st 2 chars mapped to normalised indicator - or is original 2 chars switch -- $leadernorm { @@ -1875,6 +2129,26 @@ tcl::namespace::eval overtype { } } } + 7PMX - 7SOS { + #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. + #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! + #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. + + #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string + set graphemeplus [lindex $undercols end] + if {$graphemeplus ne "\0"} { + append graphemeplus $code + } else { + set graphemeplus $code + } + lset undercols end $graphemeplus + #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. + #we need to manually cache the item with it's proper width + variable grapheme_widths + #stripped and plus version keys pointing to same length + dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] + + } default { } @@ -1895,51 +2169,30 @@ tcl::namespace::eval overtype { #consider also if there are other codes that should be stacked..? } - if {!$test_mode} { - #fill columns to width with spaces, and carry over stacks - we will have to keep track of where the underlying data ends manually - TODO - #Specifying a width is suitable for terminal-like applications and text-blocks - if {$opt_width ne "\uFFEF"} { - if {[llength $understacks]} { - set cs $u_codestack - set gs $u_gx_stack - } else { - set cs [list] - set gs [list] - } - if {[llength $undercols]< $opt_width} { - set diff [expr {$opt_width- [llength $undercols]}] - if {$diff > 0} { - lappend undercols {*}[lrepeat $diff " "] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } + #NULL empty cell indicator + if {$opt_width ne "\uFFEF"} { + if {[llength $understacks]} { + set cs $u_codestack + set gs $u_gx_stack + } else { + set cs [list] + set gs [list] } - } else { - #NULL empty cell indicator - if {$opt_width ne "\uFFEF"} { - if {[llength $understacks]} { - set cs $u_codestack - set gs $u_gx_stack - } else { - set cs [list] - set gs [list] - } - if {[llength $undercols]< $opt_width} { - set diff [expr {$opt_width- [llength $undercols]}] - if {$diff > 0} { - lappend undercols {*}[lrepeat $diff "\u0000"] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } + if {[llength $undercols]< $opt_width} { + set diff [expr {$opt_width- [llength $undercols]}] + if {$diff > 0} { + #set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower + lappend undercols {*}[lrepeat $diff "\u0000"] + lappend understacks {*}[lrepeat $diff $cs] + lappend understacks_gx {*}[lrepeat $diff $gs] } } - } + if {$opt_width ne "\uFFEF"} { - set colwidth $opt_width + set renderwidth $opt_width } else { - set colwidth [llength $undercols] + set renderwidth [llength $undercols] } @@ -1972,23 +2225,31 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- --- --- #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left of the right number of columns. + #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpad_overlay [string repeat " " [expr {$opt_colstart -1}]] - append startpad_overlay $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - if {$startpad_overlay ne ""} { - if {[punk::ansi::ta::detect $startpad_overlay]} { - set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] + set startpadding [string repeat " " [expr {$opt_colstart -1}]] + #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + if {$startpadding ne "" || $overdata ne ""} { + if {[punk::ansi::ta::detect $overdata]} { + set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] } else { #single plaintext part - set overmap [list $startpad_overlay] + set overmap [list $startpadding$overdata] } } else { set overmap [list] } - #set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] #### + + #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) + #will that allow some optimisations? + + #todo - detect repeated transparent char in overlay + #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. + # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data + #we should be able to optimize to pass through the underlay?? + #??? set colcursor $opt_colstart #TODO - make a little virtual column object @@ -2010,19 +2271,78 @@ tcl::namespace::eval overtype { #experiment set overlay_grapheme_control_stacks [list] foreach {pt code} $overmap { - - #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack + if {$pt ne ""} { + #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + append pt_overchars $pt + #will get empty pt between adjacent codes + if {!$crm_mode} { + + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] + set is_ptrun [regexp $re $pt] + + #leading only? we would have to check for graphemes at the trailing boundary? + #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] + #set is_ptrun [regexp -indices $re $pt runrange] + #if {$is_ptrun && 1} { + #} + } + if {$is_ptrun} { + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) + set len [string length $pt] + set g_element [list g $p1] + + #lappend overstacks {*}[lrepeat $len $o_codestack] + #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] + #incr i_o $len + #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] + #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] + + set pi 0 + incr i_o $len + while {$pi < $len} { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + lappend overlay_grapheme_control_list $g_element + lappend overlay_grapheme_control_stacks $o_codestack + incr pi + } + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } else { + set tsbegin [clock micros] + foreach grapheme_original [punk::char::grapheme_split $pt] { + set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" + foreach grapheme [punk::char::grapheme_split $pt_crm] { + if {$grapheme eq "\n"} { + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] + } else { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" + } } #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc @@ -2030,40 +2350,92 @@ tcl::namespace::eval overtype { # that pure resets are fairly common - more so than leading resets with other info # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. if {$code ne ""} { - lappend overlay_grapheme_control_stacks $o_codestack - #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[regexp {\x1b7|\x1b\[s} $code]} { - #experiment - #cursor_save - for the replays review. - #jmn - #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - lappend overlay_grapheme_control_list [list other $code] - } elseif {[regexp {\x1b8|\x1b\[u} $code]} { - #experiment - #cursor_restore - for the replays - set o_codestack [list $temp_cursor_saved] - lappend overlay_grapheme_control_list [list other $code] + #we need to immediately set crm_mode here if \x1b\[3h received + if {$code eq "\x1b\[3h"} { + set crm_mode 1 + } elseif {$code eq "\x1b\[3l"} { + set crm_mode 0 + } + #else crm_mode could be set either way from options + if {$crm_mode && $code ne "\x1b\[00001E"} { + #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? + #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. + set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] + #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop + set chars [split $code_as_pt ""] + set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } + foreach c $chars { + if {$c eq "\n"} { + #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish + lappend codeparts [list crmcontrol "\x1b\[00001E"] + } else { + if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { + set existing [lindex $codeparts end 1] + lset codeparts end [list g [string cat $existing $c]] + } else { + lappend codeparts [list g $c] + } + } + } + + set partidx 0 + foreach record $codeparts { + lassign $record rtype rval + switch -exact -- $rtype { + g { + append pt_overchars $rval + foreach grapheme [punk::char::grapheme_split $rval] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + crmcontrol { + #leave o_codestack + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol $rval] + } + } + } } else { - if {[punk::ansi::codetype::is_gx_open $code]} { - set o_gxstack [list "gx0_on"] - lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - set o_gxstack [list] - lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } else { + lappend overlay_grapheme_control_stacks $o_codestack + #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[regexp {\x1b7|\x1b\[s} $code]} { + #experiment + #cursor_save - for the replays review. + #jmn + #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] + lappend overlay_grapheme_control_list [list other $code] + } elseif {[regexp {\x1b8|\x1b\[u} $code]} { + #experiment + #cursor_restore - for the replays + set o_codestack [list $temp_cursor_saved] lappend overlay_grapheme_control_list [list other $code] + } else { + #review + if {[punk::ansi::codetype::is_gx_open $code]} { + set o_gxstack [list "gx0_on"] + lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } elseif {[punk::ansi::codetype::is_gx_close $code]} { + set o_gxstack [list] + lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } else { + lappend overlay_grapheme_control_list [list other $code] + } } } } @@ -2089,11 +2461,12 @@ tcl::namespace::eval overtype { # -- --- --- #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 - if {$opt_overflow} { - #somewhat counterintuitively - overflow true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. + if {$opt_expand_right} { + #expand_right true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. + #we currently only support horizontal expansion to the right (review regarding RTL text!) set overflow_idx -1 } else { - #overflow zero - we can't grow beyond our column width - so we get ellipsis or truncation + #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation if {$opt_width ne "\uFFEF"} { set overflow_idx [expr {$opt_width}] } else { @@ -2134,10 +2507,7 @@ tcl::namespace::eval overtype { #movements only occur within the overlay range. #an underlay is however not necessary.. e.g - #renderline -overflow 1 "" data - #foreach {pt code} $overmap {} - set insert_mode $opt_insert_mode ;#default 1 - set autowrap_mode $opt_autowrap_mode ;#default 1 + #renderline -expand_right 1 "" data #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} @@ -2163,13 +2533,28 @@ tcl::namespace::eval overtype { switch -- $type { g { set ch $item + #crm_mode affects both graphic and control + if {0 && $crm_mode} { + set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] + set chars [string map [list \n "\x1b\[00001E"] $chars] + if {[llength [split $chars ""]] > 1} { + priv::render_unapplied $overlay_grapheme_control_list $gci + #prefix the unapplied controls with the string version of this control + set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + set unapplied [join $unapplied_list ""] + #incr idx_over + break + } else { + set ch $chars + } + } incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. if {($idx < ($opt_colstart -1))} { incr idx [grapheme_width_cached $ch] continue } #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width - set within_undercols [expr {$idx <= $colwidth-1}] + set within_undercols [expr {$idx <= $renderwidth-1}] #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, @@ -2194,18 +2579,29 @@ tcl::namespace::eval overtype { #linefeed after final column #puts "---c at overflow_idx=$overflow_idx" incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently priv::render_unapplied $overlay_grapheme_control_list $gci break } else { #linefeed occurred in middle or at end of text #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" - incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 - set instruction lf_mid - priv::render_unapplied $overlay_grapheme_control_list $gci - break + if {$insert_mode == 0} { + incr cursor_row + if {$idx == -1 || $overflow_idx > $idx} { + #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + } + set instruction lf_mid + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } else { + incr cursor_row + #don't adjust the overflow_idx + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction lf_mid + break ;# could have overdata following the \n - don't keep processing + } } } @@ -2284,23 +2680,35 @@ tcl::namespace::eval overtype { #tab of some length dependent on tabstops/elastic tabstop settings? } } elseif {$idx >= $overflow_idx} { - #jmn? - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #don't incr idx beyond the overflow_idx - #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied - incr idx_over -1 - #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too - priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# - set instruction overflow - break + #REVIEW + set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control + lassign $next_gc next_type next_item + if {$autowrap_mode || $next_type ne "g"} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #don't incr idx beyond the overflow_idx + #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied + incr idx_over -1 + #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too + priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# + set instruction overflow + break + } else { + #no point throwing back to caller for each grapheme that is overflowing + #without this branch - renderline would be called with overtext reducing only by one grapheme per call + #processing a potentially long overtext each time (ie - very slow) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #JMN4 + + } } } else { #review. - #This corresponds to opt_overflow being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) + #overflow_idx = -1 + #This corresponds to expand_right being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) } - if {($do_transparency && [regexp $opt_transparent $ch])} { + if {($do_transparency && [regexp $opt_transparent $ch])} { #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) if {$idx > [llength $outcols]-1} { lappend outcols " " @@ -2311,6 +2719,7 @@ tcl::namespace::eval overtype { } else { #todo - punk::char::char_width set g [lindex $outcols $idx] + #JMN set uwidth [grapheme_width_cached $g] if {[lindex $outcols $idx] eq ""} { #2nd col of 2-wide char in underlay @@ -2438,7 +2847,7 @@ tcl::namespace::eval overtype { } incr idx } - if {($cursor_column < [llength $outcols]) || $overflow_idx == -1 || $test_mode} { + if {($cursor_column < [llength $outcols]) || $overflow_idx == -1} { incr cursor_column } } elseif {$uwidth > 1} { @@ -2472,12 +2881,6 @@ tcl::namespace::eval overtype { priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode incr idx incr cursor_column - if {$overflow_idx !=-1 && !$test_mode} { - #overflow - if {$cursor_column > [llength $outcols]} { - set cursor_column [llength $outcols] - } - } } } } @@ -2485,13 +2888,29 @@ tcl::namespace::eval overtype { } - other { + other - crmcontrol { + if {$crm_mode && $type ne "crmcontrol" && $item ne "\x1b\[00001E"} { + if {$item eq "\x1b\[3l"} { + set crm_mode 0 + } else { + #When our initial overlay split was done - we weren't in crm_mode - so there are codes that weren't mapped to unicode control character representations + #set within_undercols [expr {$idx <= $renderwidth-1}] + #set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item] + set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] + priv::render_unapplied $overlay_grapheme_control_list $gci + #prefix the unapplied controls with the string version of this control + set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + set unapplied [join $unapplied_list ""] + + break + } + } + #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. - #we should probably therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore + #we should possibly therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore? set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $item] #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' - set matchinfo [list] #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping @@ -2501,15 +2920,18 @@ tcl::namespace::eval overtype { set c1c2c3 [tcl::string::range $code 0 2] #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. - #(surprising - but presumably ) + #(somewhat surprising) set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[< 1006\ \x1b\[ 7CSI\ + \x1bY 7MAP\ + \x1bP 7DCS\ + \x90 8DCS\ \x9b 8CSI\ \x1b\] 7OSC\ \x9d 8OSC\ \x1b 7ESC\ - ] $c1c2c3] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars + ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) #we leave the tail of the code unmapped for now switch -- $leadernorm { @@ -2519,20 +2941,62 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] } 7CSI - 7OSC { + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + set codenorm $leadernorm[tcl::string::range $code 2 end] + } + 7DCS { + #ESC P + #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] } - 7ESC { + 8DCS { + #8-bit Device Control String set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] } + 7MAP { + #map to another type of code to share implementation branch + set codenorm $leadernorm[tcl::string::range $code 1 end] + } + 7ESC { + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + set codenorm $leadernorm[tcl::string::range $code 1 end] + } 8CSI - 8OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] } default { + puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" #we haven't made a mapping for this + #could in theory be 1,2 or 3 in len + #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches set codenorm $code } } + switch -- $leadernorm { + 7MAP { + switch -- [lindex $codenorm 4] { + Y { + #vt52 movement. we expect 2 chars representing position (limited range) + set params [tcl::string::range $codenorm 5 end] + if {[tcl::string::length $params] != 2} { + #shouldn't really get here or need this branch if ansi splitting was done correctly + puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + set line [tcl::string::index $params 5] + set column [tcl::string::index $params 1] + set r [expr {[scan $line %c] -31}] + set c [expr {[scan $column %c] -31}] + + #MAP to: + #CSI n;m H - CUP - Cursor Position + set leadernorm 7CSI + set codenorm "$leadernorm${r}\;${c}H" + } + } + } + } + #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. switch -- $leadernorm { 1006 { @@ -2551,50 +3015,62 @@ tcl::namespace::eval overtype { {7CSI} - {8CSI} { set param [tcl::string::range $codenorm 4 end-1] #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" - switch -- [tcl::string::index $codenorm end] { - D { - #Col move - #puts stdout "<-back" - #cursor back - #left-arrow/move-back when ltr mode - set num $param + set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode + + switch -exact -- $code_end { + A { + #Row move - up + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #todo + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + incr cursor_row -$num - set version 2 - if {$version eq "2"} { - #todo - startcolumn offset! - if {$cursor_column - $num >= 1} { - incr idx -$num - incr cursor_column -$num - } else { - if {!$autowrap_mode} { - set cursor_column 1 - set idx 0 - } else { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr cursor_column -$num - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmovebackward - break - } - } - } else { - incr idx -$num - incr cursor_column -$num - if {$idx < $opt_colstart-1} { - #wrap to previous line and position cursor at end of data - set idx [expr {$opt_colstart-1}] - set cursor_column $opt_colstart - } + if {$cursor_row < 1} { + set cursor_row 1 } + + #ensure rest of *overlay* is emitted to remainder + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction up + #retain cursor_column + break + } + B { + #CUD - Cursor Down + #Row move - down + lassign [split $param {;}] num modifierkey + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move down + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + incr cursor_row $num + + + incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break } C { + #CUF - Cursor Forward #Col move #puts stdout "->forward" #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. #cursor forward #right-arrow/move forward - set num $param + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} #todo - retrict to moving 1 position past datalen? restrict to column width? @@ -2610,7 +3086,7 @@ tcl::namespace::eval overtype { if {$overflow_idx == -1} { incr max } - if {$test_mode && $cursor_column == $max+1} { + if {$cursor_column == $max+1} { #move_forward while in overflow incr cursor_column -1 } @@ -2627,7 +3103,7 @@ tcl::namespace::eval overtype { } #horizontal movement beyond line extent needs to wrap - throw back to caller - #we may have both overflow_rightand unapplied data + #we may have both overflow_right and unapplied data #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) #leave row as is - caller will need to determine how many rows the column-movement has consumed incr cursor_column $num ;#give our caller the necessary info as columns from start of row @@ -2642,7 +3118,8 @@ tcl::namespace::eval overtype { } } } else { - if {!$opt_overflow || ($cursor_column + $num) <= [llength $outcols+1]} { + #review - dead branch + if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} { incr idx $num incr cursor_column $num } else { @@ -2692,85 +3169,311 @@ tcl::namespace::eval overtype { } } } - G { + D { #Col move - #move absolute column - #adjust to colstart - as column 1 is within overlay - #??? - set idx [expr {$param + $opt_colstart -1}] - set cursor_column $param - error "renderline absolute col move ESC G unimplemented" - } - A { - #Row move - up - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set num $param + #puts stdout "<-back" + #cursor back + #left-arrow/move-back when ltr mode + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } if {$num eq ""} {set num 1} - incr cursor_row -$num - if {$cursor_row < 1} { - set cursor_row 1 + set version 2 + if {$version eq "2"} { + #todo - startcolumn offset! + if {$cursor_column - $num >= 1} { + incr idx -$num + incr cursor_column -$num + } else { + if {!$autowrap_mode} { + set cursor_column 1 + set idx 0 + } else { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr cursor_column -$num + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmovebackward + break + } + } + } else { + incr idx -$num + incr cursor_column -$num + if {$idx < $opt_colstart-1} { + #wrap to previous line and position cursor at end of data + set idx [expr {$opt_colstart-1}] + set cursor_column $opt_colstart + } } - - #ensure rest of *overlay* is emitted to remainder + } + E { + #CNL - Cursor Next Line + if {$param eq ""} { + set downmove 1 + } else { + set downmove [expr {$param}] + } + puts stderr "renderline CNL down-by-$downmove" + set cursor_column 1 + set cursor_row [expr {$cursor_row + $downmove}] + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] incr idx_over priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up - #retain cursor_column - break + set instruction move + break + } - B { - #Row move - down - set num $param + F { + #CPL - Cursor Previous Line + if {$param eq ""} { + set upmove 1 + } else { + set upmove [expr {$param}] + } + puts stderr "renderline CPL up-by-$upmove" + set cursor_column 1 + set cursor_row [expr {$cursor_row -$upmove}] + if {$cursor_row < 1} { + set cursor_row 1 + } + set idx [expr {$cursor_column - 1}] set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move down - if {$num eq ""} {set num 1} - incr cursor_row $num - - - incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet + incr idx_over priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break + set instruction move + break + + } + G { + #CHA - Cursor Horizontal Absolute (move to absolute column no) + if {$param eq ""} { + set targetcol 1 + } else { + set targetcol $param + if {![string is integer -strict $targetcol]} { + puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Unrecognised parameter '$param'" + } + set targetcol [expr {$param}] + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$targetcol > $max} { + puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Param '$param' > max: $max" + set targetcol $max + } + } + #adjust to colstart - as column 1 is within overlay + #??? REVIEW + set idx [expr {($targetcol -1) + $opt_colstart -1}] + + + set cursor_column $targetcol + #puts stderr "renderline absolute col move ESC G (TEST)" } H - f { - #$re_both_move - lassign [split $param {;}] row col - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #lassign $matchinfo _match row col + #CSI n;m H - CUP - Cursor Position - if {$col eq ""} {set col 1} - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$col > $max} { - set cursor_column $max + #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes + # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' + # - REVIEW + #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf + + #test e.g ansicat face_2.ans + #$re_both_move + lassign [split $param {;}] paramrow paramcol + #missing defaults to 1 + #CSI ;5H = CSI 1;5H -> row 1 col 5 + #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 + + if {$paramcol eq ""} {set paramcol 1} + if {$paramrow eq ""} {set paramrow 1} + if {![string is integer -strict $paramcol] || ![string is integer -strict $paramrow]} { + puts stderr "renderline CUP (CSI H) unrecognised param $param" + #ignore? } else { - set cursor_column $col + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$paramcol > $max} { + set target_column $max + } else { + set target_column [expr {$paramcol}] + } + + + if {$paramrow < 1} { + puts stderr "renderline CUP (CSI H) bad row target 0. Assuming 1" + set target_row 1 + } else { + set target_row [expr {$paramrow}] + } + if {$target_row == $cursor_row} { + #col move only - no need for break and move + #puts stderr "renderline CUP col move only to col $target_column param:$param" + set cursor_column $target_column + set idx [expr {$cursor_column -1}] + } else { + set cursor_row $target_row + set cursor_column $target_column + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + } } - set idx [expr {$cursor_column -1}] + } + J { + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + #CSI ? Pn J - selective erase + puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of screen + } + 1 { + #clear from cursor to beginning of screen + } + 2 { + #clear entire screen + #ansi.sys - move cursor to upper left REVIEW + set cursor_row 1 + set cursor_column 1 + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + if {[llength $outcols]} { + priv::render_erasechar 0 [llength $outcols] + } + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction clear_and_move + break + } + 3 { + #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? - if {$row eq ""} {set row 1} - set cursor_row $row - if {$cursor_row < 1} { - set cursor_row 1 + } + default { + } + } + + } } + } + K { + #see DECECM regarding background colour + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param [string range $param 1 end] ;#chop qmark + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line - depending on DECSCA + } + 1 { + #clear from cursor to beginning of line - depending on DECSCA - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break + } + 2 { + #clear entire line - depending on DECSCA + } + default { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line + } + 1 { + #clear from cursor to beginning of line + + } + 2 { + #clear entire line + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + } + } + } + L { + puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + M { + #CSI Pn M - DL - Delete Line + puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" } + T { + #CSI Pn T - SD Pan Up (empty lines introduced at top) + #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) + #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display + if {$param eq "" || $param eq "0"} {set param 1} + if {[string index $param end] eq "+"} { + puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } else { + puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } X { - puts stderr "X - $param" + puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" #ECH - erase character if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase priv::render_erasechar $idx $param #cursor position doesn't change. } + q { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + {"} { + #DECSCA - Select Character Protection Attribute + #(for use with selective erase: DECSED and DECSEL) + set param [tcl::string::range $codenorm 4 end-2] + if {$param eq ""} {set param 0} + #TODO - store like SGR in stacks - replays? + switch -exact -- $param { + 0 - 2 { + #canerase + puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 1 { + #cannoterase + puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } r { #$re_decstbm #https://www.vt100.net/docs/vt510-rm/DECSTBM.html @@ -2789,78 +3492,119 @@ tcl::namespace::eval overtype { break } s { - # - todo - make ansi.sys CSI s cursor save only apply for certain cases? - may need to support DECSLRM instead which uses same code - - #$re_cursor_save - #cursor save could come after last column - if {$overflow_idx != -1 && $idx == $overflow_idx} { - #bartman2.ans test file - fixes misalignment at bottom of dialog bubble - #incr cursor_row - #set cursor_column 1 - #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) - set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] - } else { - set cursor_saved_position [list row $cursor_row column $cursor_column] - } - #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. - #we need the SGR and gx overlay codes prior to the cursor_save + #code conflict between ansi emulation and DECSLRM - REVIEW + #ANSISYSSC (when no parameters) - like other terminals - essentially treat same as DECSC + # todo - when parameters - support DECSLRM instead + + if {$param ne ""} { + #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) + lassign [split $param {;} margin_left margin_right + puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$margin_left eq ""} { + set margin_left 1 + } + set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? + if {$margin_right eq ""} { + set margin_right $columns_per_page + } + puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" + if {![string is integer -strict $margin_left] || $margin_left < 0} { + puts stderr "DECSLRM invalid margin_left" + } + if {![string is integer -strict $margin_right] || $margin_right < 0} { + puts stderr "DECSLRM invalid margin_right" + } + set scrolling_region_size [expr {$margin_right - $margin_left}] + if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { + puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" + } + #todo - #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. - #set sgr_stack [lindex $understacks $idx] - #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) - - set sgr_stack [list] - set gx_stack [list] - - #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. - #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. - - foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { - lassign $gc type code - #types g other sgr gx0 - switch -- $type { - gx0 { - #code is actually a stand-in for the graphics on/off code - not the raw code - #It is either gx0_on or gx0_off - set gx_stack [list $code] - } - sgr { - #code is the raw code - if {[punk::ansi::codetype::is_sgr_reset $code]} { - #jmn - set sgr_stack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set sgr_stack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #often we don't get resets - and codes just pile up. - #as a first step to simplifying - at least remove earlier straight up dupes - set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) - set sgr_stack [lremove $sgr_stack {*}$dup_posns] - lappend sgr_stack $code + + } else { + #DECSC + #//notes on expected behaviour: + #DECSC - saves following items in terminal's memory + #cursor position + #character attributes set by the SGR command + #character sets (G0,G1,G2 or G3) currently in GL and GR + #Wrap flag (autowrap or no autowrap) + #State of origin mode (DECOM) + #selective erase attribute + #any single shift 2 (SS2) or single shift 3(SSD) functions sent + + #$re_cursor_save + #cursor save could come after last column + if {$overflow_idx != -1 && $idx == $overflow_idx} { + #bartman2.ans test file - fixes misalignment at bottom of dialog bubble + #incr cursor_row + #set cursor_column 1 + #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) + set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] + } else { + set cursor_saved_position [list row $cursor_row column $cursor_column] + } + #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. + #we need the SGR and gx overlay codes prior to the cursor_save + + #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. + #set sgr_stack [lindex $understacks $idx] + #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) + + set sgr_stack [list] + set gx_stack [list] + + #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. + #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. + + foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { + lassign $gc type code + #types g other sgr gx0 + switch -- $type { + gx0 { + #code is actually a stand-in for the graphics on/off code - not the raw code + #It is either gx0_on or gx0_off + set gx_stack [list $code] + } + sgr { + #code is the raw code + if {[punk::ansi::codetype::is_sgr_reset $code]} { + #jmn + set sgr_stack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set sgr_stack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #often we don't get resets - and codes just pile up. + #as a first step to simplifying - at least remove earlier straight up dupes + set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) + set sgr_stack [lremove $sgr_stack {*}$dup_posns] + lappend sgr_stack $code + } } } } - } - set cursor_saved_attributes "" - switch -- [lindex $gx_stack 0] { - gx0_on { - append cursor_saved_attributes "\x1b(0" - } - gx0_off { - append cursor_saved_attributes "\x1b(B" + set cursor_saved_attributes "" + switch -- [lindex $gx_stack 0] { + gx0_on { + append cursor_saved_attributes "\x1b(0" + } + gx0_off { + append cursor_saved_attributes "\x1b(B" + } } - } - #append cursor_saved_attributes [join $sgr_stack ""] - append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] + #append cursor_saved_attributes [join $sgr_stack ""] + append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] - #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. + #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. - #don't incr index - or the save will cause cursor to move to the right - #carry on - + #don't incr index - or the save will cause cursor to move to the right + #carry on + } } u { + #ANSISYSRC save cursor (when no parameters) (DECSC) + #$re_cursor_restore #we are going to jump somewhere.. for now we will assume another line, and process accordingly. #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) @@ -2901,135 +3645,260 @@ tcl::namespace::eval overtype { set instruction restore_cursor break } + "{" { + + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + "}" { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + ' { + puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + default { + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + } + } ~ { - #$re_vt_sequence - #lassign $matchinfo _match key mod - lassign [split $param {;}] key mod - - #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ - # - #e.g esc \[2~ insert esc \[2;2~ shift-insert - #mod - subtract 1, and then use bitmask - #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) - #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" - if {$key eq "1"} { - #home - } elseif {$key eq "2"} { - #Insert - if {$mod eq ""} { - #no modifier key - set insert_mode [expr {!$insert_mode}] - #rather than set the cursor - we return the insert mode state so the caller can decide + set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ + switch -exact -- $code_secondlast { + ' { + #DECDC - editing sequence - Delete Column + puts stderr "renderline warning - DECDC - unimplemented" } - } elseif {$key eq "3"} { - #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end - switch -- $mod { - "" { - priv::render_delchar $idx - } - "5" { - #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) + default { + #$re_vt_sequence + lassign [split $param {;}] key mod + + #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ + # + #e.g esc \[2~ insert esc \[2;2~ shift-insert + #mod - subtract 1, and then use bitmask + #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) + #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" + if {$key eq "1"} { + #home + } elseif {$key eq "2"} { + #Insert + if {$mod eq ""} { + #no modifier key + set insert_mode [expr {!$insert_mode}] + #rather than set the cursor - we return the insert mode state so the caller can decide + } + } elseif {$key eq "3"} { + #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end + switch -- $mod { + "" { + priv::render_delchar $idx + } + "5" { + #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) + } + } + } elseif {$key eq "4"} { + #End + } elseif {$key eq "5"} { + #pgup + } elseif {$key eq "6"} { + #pgDn + } elseif {$key eq "7"} { + #Home + #?? + set idx [expr {$opt_colstart -1}] + set cursor_column 1 + } elseif {$key eq "8"} { + #End + } elseif {$key eq "11"} { + #F1 - or ESCOP or e.g shift F1 ESC\[1;2P + } elseif {$key eq "12"} { + #F2 - or ESCOQ + } elseif {$key eq "13"} { + #F3 - or ESCOR + } elseif {$key eq "14"} { + #F4 - or ESCOS + } elseif {$key eq "15"} { + #F5 or shift F5 ESC\[15;2~ + } elseif {$key eq "17"} { + #F6 + } elseif {$key eq "18"} { + #F7 + } elseif {$key eq "19"} { + #F8 + } elseif {$key eq "20"} { + #F9 + } elseif {$key eq "21"} { + #F10 + } elseif {$key eq "23"} { + #F11 + } elseif {$key eq "24"} { + #F12 } + } - } elseif {$key eq "4"} { - #End - } elseif {$key eq "5"} { - #pgup - } elseif {$key eq "6"} { - #pgDn - } elseif {$key eq "7"} { - #Home - #?? - set idx [expr {$opt_colstart -1}] - set cursor_column 1 - } elseif {$key eq "8"} { - #End - } elseif {$key eq "11"} { - #F1 - or ESCOP or e.g shift F1 ESC\[1;2P - } elseif {$key eq "12"} { - #F2 - or ESCOQ - } elseif {$key eq "13"} { - #F3 - or ESCOR - } elseif {$key eq "14"} { - #F4 - or ESCOS - } elseif {$key eq "15"} { - #F5 or shift F5 ESC\[15;2~ - } elseif {$key eq "17"} { - #F6 - } elseif {$key eq "18"} { - #F7 - } elseif {$key eq "19"} { - #F8 - } elseif {$key eq "20"} { - #F9 - } elseif {$key eq "21"} { - #F10 - } elseif {$key eq "23"} { - #F11 - } elseif {$key eq "24"} { - #F12 } } h - l { + #set mode unset mode #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? #$re_mode if first after CSI is "?" #some docs mention ESC=h|l - not seen on windows terminals.. review #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html - if {[tcl::string::index $codenorm 4] eq "?"} { - set num [tcl::string::range $codenorm 5 end-1] ;#param between ? and h|l - #lassign $matchinfo _match num type - switch -- $num { - 5 { - #DECSNM - reverse video - #How we simulate this to render within a block of text is an open question. - #track all SGR stacks and constantly flip based on the current SGR reverse state? - #It is the job of the calling loop to do this - so at this stage we'll just set the states - #DECAWM autowrap - if {$type eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 - } + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = + switch -exact -- $modegroup { + ? { + set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l + #one or more modes can be set + set smparam_list [split $smparams {;}] + foreach num $smparam_list { + switch -- $num { + "" { + #ignore empties e.g extra/trailing semicolon in params + } + 5 { + #DECSNM - reverse video + #How we simulate this to render within a block of text is an open question. + #track all SGR stacks and constantly flip based on the current SGR reverse state? + #It is the job of the calling loop to do this - so at this stage we'll just set the states + + if {$code_end eq "h"} { + #set (enable) + set reverse_mode 1 + } else { + #reset (disable) + set reverse_mode 0 + } + } + 7 { + #DECAWM autowrap + if {$code_end eq "h"} { + #set (enable) + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? + # presume not usually - but sanity check with warning for now. + if {$idx >= $overflow_idx} { + puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" + } + } else { + #reset (disable) + set autowrap_mode 0 + #REVIEW! + set overflow_idx -1 + } + } + 25 { + if {$code_end eq "h"} { + #visible cursor + + } else { + #invisible cursor + + } + } + 117 { + #DECECM - Erase Color Mode + #https://invisible-island.net/ncurses/ncurses.faq.html + #The Erase color selection controls the background color used when text is erased or new + #text is scrolled on to the screen. Screen background causes newly erased areas or + #scrolled text to be written using color index zero, the screen background. This is VT + #and DECterm compatible. Text background causes erased areas or scrolled text to be + #written using the current text background color. This is PC console compatible and is + #the factory default. + + #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen + } + } } - 7 { - #DECAWM autowrap - if {$type eq "h"} { - #set (enable) - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width + } + = { + set num [tcl::string::range $codenorm 5 end-1] ;#param between = and h|l + puts stderr "overtype::renderline CSI=...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + default { + #e.g CSI 4 h + set num [tcl::string::range $codenorm 4 end-1] ;#param before h|l + switch -exact -- $num { + 3 { + puts stderr "CRM MODE $code_end" + #CRM - Show control character mode + # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' + # + #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 + #https://vt100.net/docs/vt510-rm/CRM.html + #NOTE - vt100 CRM always does auto-wrap at right margin. + #disabling auto-wrap in set-up or by sequence is disabled. + #We should default to turning off auto-wrap when crm_mode enabled.. but + #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) + #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, + #although this would be potentially an annoying difference to some.. REVIEW + if {$code_end eq "h"} { + set crm_mode 1 + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + set crm_mode 0 } - #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? presume not - but sanity check for now. - if {$idx >= $overflow_idx} { - puts stderr "renderline error - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" + } + 4 { + #IRM - Insert/Replace Mode + if {$code_end eq "h"} { + #CSI 4 h + set insert_mode 1 + } else { + #CSI 4 l + #replace mode + set insert_mode 0 } - } else { - #reset (disable) - set autowrap_mode 0 - set overflow_idx -1 + } + default { + puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" } } - 25 { - if {$type eq "h"} { - #visible cursor + } + } + } + | { + switch -- [tcl::string::index $codenorm end-1] { + {$} { + #CSI ... $ | DECSCPP set columns per page- (recommended in vt510 docs as preferable to DECCOLM) + #real terminals generally only supported 80/132 + #some other virtuals support any where from 2 to 65,536? + #we will allow arbitrary widths >= 2 .. to some as yet undetermined limit. + #CSI $ | + #empty or 0 param is 80 for compatibility - other numbers > 2 accepted + set page_width -1 ;#flag as unset + if {$param eq ""} { + set page_width 80 + } elseif {[string is integer -strict $param] && $param >=2 0} { + set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr + } else { + puts stderr "overtype::renderline unacceptable DECSPP value '$param'" + } - } else { - #invisible cursor + if {$page_width > 2} { + puts stderr "overtype::renderline DECSCPP - not implemented - but selected width '$page_width' looks ok" + #if cursor already beyond new page_width - will move to right colum - otherwise no cursor movement - } } - } - } else { - puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + default { + puts stderr "overtype::renderline unrecognised CSI code ending in pipe (|) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } } } default { @@ -3038,24 +3907,50 @@ tcl::namespace::eval overtype { } } 7ESC { - #$re_other_single - switch -- [tcl::string::index $codenorm end] { + # + #re_other_single {\x1b(D|M|E)$} + #also vt52 Y.. + #also PM \x1b^...(ST) + switch -- [tcl::string::index $codenorm 4] { + c { + #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! + puts stderr "renderline reset" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction reset + break + } D { #\x84 #index (IND) #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" - puts stderr "ESC D not fully implemented" + puts stderr "renderline ESC D not fully implemented" incr cursor_row priv::render_unapplied $overlay_grapheme_control_list $gci set instruction down #retain cursor_column break } + E { + #\x85 + #review - is behaviour different to lf? + #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL + #leave implementation until logic for is set in stone... still under review + #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. + # + #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" + puts stderr "overtype::renderline ESC E unimplemented" + + } + H { + #\x88 + #Tab Set + puts stderr "overtype::renderline ESC H tab set unimplemented" + } M { #\x8D #Reverse Index (RI) #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" - puts stderr "ESC M not fully implemented" + puts stderr "overtype::renderline ESC M not fully implemented" set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #move up @@ -3069,31 +3964,185 @@ tcl::namespace::eval overtype { #retain cursor_column break } - E { - #\x85 - #review - is behaviour different to lf? - #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL - #leave implementation until logic for is set in stone... still under review - #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. - # - #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" - puts stderr "ESC E unimplemented" + N { + #\x8e - affects next character only + puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + O { + #\x8f - affects next character only + puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + P { + #\x90 + #DCS - shouldn't get here - handled in 7DCS branch + #similarly \] OSC (\x9d) and \\ (\x9c) ST + } + V { + #\x96 + + } + W { + #\x97 + } + X { + #\x98 + #SOS + if {[string index $code end] eq "\007"} { + set sos_content [string range $code 2 end-1] ;#ST is \007 + } else { + set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #return in some useful form to the caller + #TODO! + lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] + puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + ^ { + #puts stderr "renderline PM" + #Privacy Message. + if {[string index $code end] eq "\007"} { + set pm_content [string range $code 2 end-1] ;#ST is \007 + } else { + set pm_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #We don't want to render it - but we need to make it available to the application + #see the textblock library in punk, for the exception we make here for single backspace. + #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix + #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' + if {$pm_content eq "\b"} { + #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" + #esc^\b\007 or esc^\besc\\ + #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs + #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. + #If the terminal has the space problem AND does support PMs - then this just won't fix it. + #The fix relies on the symbol-supplier to cooperate by appending esc^\b\esc\\ to the problematic symbols. + + #priv::render_addchar $idx $code [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #idx has been incremented after last grapheme added + priv::render_append_to_char [expr {$idx -1}] $code + } + #lappend to a dict element in the result for application-specific processing + lappend pm_list $pm_content + } + _ { + #APC Application Program Command + #just warn for now.. + puts stderr "overtype::renderline ESC_ APC command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + } + + } + 7DCS - 8DCS { + puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #ST (string terminator) \x9c or \x1b\\ + if {[tcl::string::index $codenorm end] eq "\x9c"} { + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c + } else { + set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ + } + + } + 7OSC - 8OSC { + # OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit + if {[tcl::string::index $codenorm end] eq "\007"} { + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007 + } else { + set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ + } + set first_colon [tcl::string::first {;} $code_content] + if {$first_colon == -1} { + #there probably should always be a colon - but we'll try to make sense of it without + set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007 + } else { + set osc_code [tcl::string::range $code_content 0 $first_colon-1] + } + switch -exact -- $osc_code { + 2 { + set newtitle [tcl::string::range $code_content 2 end] + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction [list set_window_title $newtitle] + break + } + 4 { + #OSC 4 - set colour palette + #can take multiple params + #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ + set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon + set cmap [dict create] + foreach {cnum spec} [split $params {;}] { + if {$cnum >= 0 and $cnum <= 255} { + #todo - parse spec from names like 'red' to RGB + #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) + #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? + dict set cmap $cnum $spec + } else { + #todo - log + puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + + } + 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 { + #OSC 10 through 17 - so called 'dynamic colours' + #can take multiple params - each successive parameter changes the next colour in the list + #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more + #10 change text foreground colour + #11 change text background colour + #12 change text cursor colour + #13 change mouse foreground colour + #14 change mouse background colour + #15 change tektronix foreground colour + #16 change tektronix background colour + #17 change highlight colour + set params [tcl::string::range $code_content 2 end] + + puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + } + 18 { + #why is this not considered one of the dynamic colours above? + #https://www.xfree86.org/current/ctlseqs.html + #tektronix cursor color + puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 99 { + #kitty desktop notifications + #https://sw.kovidgoyal.net/kitty/desktop-notifications/ + # 99 ; metadata ; payload + puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 104 { + #reset colour palette + #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt + puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction [list reset_colour_palette] + break + } + 1337 { + #iterm2 graphics and file transfer + puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" + } + 5113 { + puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" } default { - puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" } } } + default { + } } - #switch -regexp -matchvar matchinfo -- $code\ - #$re_mode { - #}\ - #default { - # puts stderr "overtype::renderline code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - #} } default { @@ -3104,7 +4153,7 @@ tcl::namespace::eval overtype { } #-------- - if {$opt_overflow == 0} { + if {$opt_expand_right == 0} { #need to truncate to the width of the original undertext #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars @@ -3130,6 +4179,23 @@ tcl::namespace::eval overtype { #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW set in_overflow 1 } + set trailing_nulls 0 + foreach ch [lreverse $outcols] { + if {$ch eq "\u0000"} { + incr trailing_nulls + } else { + break + } + } + if {$trailing_nulls} { + set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}] + } else { + set first_tail_null_posn -1 + } + + #puts stderr "first_tail_null_posn: $first_tail_null_posn" + #puts stderr "colview: [ansistring VIEW $outcols]" + foreach ch $outcols { #puts "---- [ansistring VIEW $ch]" @@ -3204,8 +4270,17 @@ tcl::namespace::eval overtype { } append outstring $gxleader append outstring $sgrleader - if {$idx+1 < $cursor_column} { - append outstring [tcl::string::map {\u0000 " "} $ch] + if {$ch eq "\u0000"} { + if {$cp437_glyphs} { + #map all nulls including at tail to space + append outstring " " + } else { + if {$trailing_nulls && $i < $first_tail_null_posn} { + append outstring " " ;#map inner nulls to space + } else { + append outstring \u0000 + } + } } else { append outstring $ch } @@ -3213,12 +4288,20 @@ tcl::namespace::eval overtype { incr i } #flower.ans good test for null handling - reverse line building - if {![ansistring length $overflow_right]} { - set outstring [tcl::string::trimright $outstring "\u0000"] - } - set outstring [tcl::string::map {\u0000 " "} $outstring] - set overflow_right [tcl::string::trimright $overflow_right "\u0000"] - set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] + #review - presence of overflow_right doesn't indicate line's trailing nulls should remain. + #The cells could have been erased? + #if {!$cp437_glyphs} { + # #if {![ansistring length $overflow_right]} { + # # set outstring [tcl::string::trimright $outstring "\u0000"] + # #} + # set outstring [tcl::string::trimright $outstring "\u0000"] + # set outstring [tcl::string::map {\u0000 " "} $outstring] + #} + + + #REVIEW + #set overflow_right [tcl::string::trimright $overflow_right "\u0000"] + #set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] set replay_codes "" if {[llength $understacks] > 0} { @@ -3275,20 +4358,24 @@ tcl::namespace::eval overtype { overflow_right $overflow_right\ unapplied $unapplied\ unapplied_list $unapplied_list\ - insert_mode $insert_mode\ - autowrap_mode $autowrap_mode\ + insert_mode $insert_mode\ + autowrap_mode $autowrap_mode\ + crm_mode $crm_mode\ + reverse_mode $reverse_mode\ insert_lines_above $insert_lines_above\ insert_lines_below $insert_lines_below\ cursor_saved_position $cursor_saved_position\ cursor_saved_attributes $cursor_saved_attributes\ cursor_column $cursor_column\ cursor_row $cursor_row\ - opt_overflow $opt_overflow\ + expand_right $opt_expand_right\ replay_codes $replay_codes\ replay_codes_underlay $replay_codes_underlay\ replay_codes_overlay $replay_codes_overlay\ + pm_list $pm_list\ ] if {$opt_returnextra == 1} { + #puts stderr "renderline: $result" return $result } else { #human/debug - map special chars to visual glyphs @@ -3313,6 +4400,7 @@ tcl::namespace::eval overtype { return $result } } else { + #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" return $outstring } #return [join $out ""] @@ -3370,8 +4458,9 @@ tcl::namespace::eval overtype::piper { } interp alias "" piper_renderline "" overtype::piper::renderline -#intended for single grapheme - but will work for multiple -#cannot contain ansi or newlines +#intended primarily for single grapheme - but will work for multiple +#WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect! +#We deliberately allow this for PM/SOS attached within a column #(a cache of ansifreestring_width calls - as these are quite regex heavy) proc overtype::grapheme_width_cached {ch} { variable grapheme_widths @@ -3439,6 +4528,7 @@ tcl::namespace::eval overtype::priv { tcl::dict::set cache_is_sgr $code $answer return $answer } + # better named render_to_unapplied? proc render_unapplied {overlay_grapheme_control_list gci} { upvar idx_over idx_over upvar unapplied unapplied @@ -3531,16 +4621,19 @@ tcl::namespace::eval overtype::priv { set o [lreplace $o $i $i] set ustacks [lreplace $ustacks $i $i] set gxstacks [lreplace $gxstacks $i $i] + } elseif {$i == 0 || $i == $nxt} { + #nothing to do } else { - + puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen" } } proc render_erasechar {i count} { upvar outcols o upvar understacks ustacks upvar understacks_gx gxstacks + upvar replay_codes_overlay replay #ECH clears character attributes from erased character positions - #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater. + #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater. if {![tcl::string::is integer -strict $count] || $count < 1} { error "render_erasechar count must be integer >= 1" } @@ -3555,29 +4648,77 @@ tcl::namespace::eval overtype::priv { } set num [expr {$end - $start + 1}] set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? - set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list]]] - set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] + #DECECM ??? + set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]] + set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review return } proc render_setchar {i c } { upvar outcols o lset o $i $c } + + #Initial usecase is for old-terminal hack to add PM-wrapped \b + #review - can be used for other multibyte sequences that occupy one column? + #combiners? diacritics? + proc render_append_to_char {i c} { + upvar outcols o + if {$i > [llength $o]-1} { + error "render_append_to_char cannot append [ansistring VIEW -lf 1 -nul 1 $c] to existing char at index $i while $i >= llength outcols [llength $o]" + } + set existing [lindex $o $i] + if {$existing eq "\0"} { + lset o $i $c + } else { + lset o $i $existing$c + } + } #is actually addgrapheme? proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { upvar outcols o upvar understacks ustacks upvar understacks_gx gxstacks - if 0 { - if {$c eq "c"} { - puts "i:$i c:$c sgrstack:[ansistring VIEW $sgrstack]" - puts "understacks:[ansistring VIEW $ustacks]" - upvar overstacks overstacks - puts "overstacks:[ansistring VIEW $overstacks]" - puts "info level 0:[info level 0]" - } + # -- --- --- + #this is somewhat of a hack.. probably not really the equivalent of proper reverse video? review + #we should ideally be able to reverse the video of a sequence that already includes SGR reverse/noreverse attributes + upvar reverse_mode do_reverse + #if {$do_reverse} { + # lappend sgrstack [a+ reverse] + #} else { + # lappend sgrstack [a+ noreverse] + #} + + #JMN3 + if {$do_reverse} { + #note we can't just look for \x1b\[7m or \x1b\[27m + # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc + + set existing_reverse_state 0 + set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] + set codestate_reverse [dict get $codeinfo codestate reverse] + switch -- $codestate_reverse { + 7 { + set existing_reverse_state 1 + } + 27 { + set existing_reverse_state 0 + } + "" { + } + } + if {$existing_reverse_state == 0} { + set rflip [a+ reverse] + } else { + #reverse of reverse + set rflip [a+ noreverse] + } + #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) + set sgrstack [list [dict get $codeinfo mergeresult] $rflip] + #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] } + + # -- --- --- set nxt [llength $o] if {!$insert_mode} { 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 new file mode 100644 index 00000000..5d76af04 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/pattern-1.2.4.tm @@ -0,0 +1,1285 @@ +#PATTERN +# - A prototype-based Object system. +# +# Julian Noble 2003 +# License: Public domain +# + +# "I need pattern" - Lexx Series 1 Episode 3 - Eating Pattern. +# +# +# Pattern uses a mixture of class-based and prototype-based object instantiation. +# +# A pattern object has 'properties' and 'methods' +# The system makes a distinction between them with regards to the access syntax for write operations, +# and yet provides unity in access syntax for read operations. +# e.g >object . myProperty +# will return the value of the property 'myProperty' +# >ojbect . myMethod +# will return the result of the method 'myMethod' +# contrast this with the write operations: +# set [>object . myProperty .] blah +# >object . myMethod blah +# however, the property can also be read using: +# set [>object . myProperty .] +# Note the trailing . to give us a sort of 'reference' to the property. +# this is NOT equivalent to +# set [>object . myProperty] +# This last example is of course calling set against a standard variable whose name is whatever value is returned by reading the property +# i.e it is equivalent in this case to: set blah + +#All objects are represented by a command, the name of which contains a leading ">". +#Any commands in the interp which use this naming convention are assumed to be a pattern object. +#Use of non-pattern commands containing this leading character is not supported. (Behaviour is undefined) + +#All user-added properties & methods of the wrapped object are accessed +# using the separator character "." +#Metamethods supplied by the patterm system are accessed with the object command using the metamethod separator ".." +# e.g to instantiate a new object from an existing 'pattern' (the equivalent of a class or prototype) +# you would use the 'Create' metamethod on the pattern object like so: +# >MyFactoryClassOrPrototypeLikeThing .. Create >NameOfNewObject +# '>NameOfNewObject' is now available as a command, with certain inherited methods and properties +# of the object it was created from. ( + + +#The use of the access-syntax separator character "." allows objects to be kept +# 'clean' in the sense that the only methods &/or properties that can be called this way are ones +# the programmer(you!) put there. Existing metamethods such as 'Create' are accessed using a different syntax +# so you are free to implement your own 'Create' method on your object that doesn't conflict with +# the metamethod. + +#Chainability (or how to violate the Law of Demeter!) +#The . access-syntax gives TCL an OO syntax more closely in line with many OO systems in other +# languages such as Python & VB, and allows left to right keyboard-entry of a deeply nested object-reference +# structure, without the need to regress to enter matching brackets as is required when using +# standard TCL command syntax. +# ie instead of: +# [[[object nextObject] getItem 4] getItem [chooseItemNumber]] doSomething +# we can use: +# >object . nextObject . getItem 4 . getItem [chooseItemNumber] . doSomething +# +# This separates out the object-traversal syntax from the TCL command syntax. + +# . is the 'traversal operator' when it appears between items in a commandlist +# . is the 'reference operator' when it is the last item in a commandlist +# , is the 'index traversal operator' (or 'nest operator') - mathematically it marks where there is a matrix 'partition'. +# It marks breaks in the multidimensional structure that correspond to how the data is stored. +# e.g obj . arraydata x y , x1 y1 z1 +# represents an element of a 5-dimensional array structured as a plane of cubes +# e.g2 obj . arraydata x y z , x1 y1 +# represents an element of a 5-dimensional array structured as a cube of planes +# The underlying storage for e.g2 might consist of something such as a Tcl array indexed such as cube($x,$y,$z) where each value is a patternlib::>matrix object with indices x1 y1 +# .. is the 'meta-traversal operator' when it appears between items in a commandlist +# .. is the 'meta-info operator'(?) when it is the last item in a commandlist + + +#!todo - Duck Typing: http://en.wikipedia.org/wiki/Duck_typing +# implement iStacks & pStacks (interface stacks & pattern stacks) + +#see also: Using namsepace ensemble without a namespace: http://wiki.tcl.tk/16975 + + +#------------------------------------------------------------ +# System objects. +#------------------------------------------------------------ +#::p::-1 ::p::internals::>metaface +#::p::0 ::p::ifaces::>null +#::p::1 ::>pattern +#------------------------------------------------------------ + +#TODO + +#investigate use of [namespace path ... ] to resolve command lookup (use it to chain iStacks?) + + +#CHANGES +#2018-09 - v 1.2.2 +# varied refactoring +# Changed invocant datastructure curried into commands (the _ID_ structure) +# Changed MAP structure to dict +# Default Method no longer magic "item" - must be explicitly set with .. DefaultMethod (or .. PatternDefaultMethod for patterns) +# updated test suites +#2018-08 - v 1.2.1 +# split ::p::predatorX functions into separate files (pkgs) +# e.g patternpredator2-1.0.tm +# patternpredator1-1.0 - split out but not updated/tested - probably obsolete and very broken +# +#2017-08 - v 1.1.6 Fairly big overhaul +# New predator function using coroutines +# Added bang operator ! +# Fixed Constructor chaining +# Added a few tests to test::pattern +# +#2008-03 - preserve ::errorInfo during var writes + +#2007-11 +#Major overhaul + new functionality + new tests v 1.1 +# new dispatch system - 'predator'. +# (preparing for multiple interface stacks, multiple invocants etc) +# +# +#2006-05 +# Adjusted 'var' expansion to use the new tcl8.5 'namespace upvar $ns v1 n1 v2 n2 ... ' feature. +# +#2005-12 +# Adjusted 'var' expansion in method/constructor etc bodies to be done 'inline' where it appears rather than aggregated at top. +# +# Fixed so that PatternVariable default applied on Create. +# +# unified interface/object datastructures under ::p:::: instead of seperate ::p::IFACE:::: +# - heading towards multiple-interface objects +# +#2005-10-28 +# 1.0.8.1 passes 80/80 tests +# >object .. Destroy - improved cleanup of interfaces & namespaces. +# +#2005-10-26 +# fixes to refsync (still messy!) +# remove variable traces on REF vars during .. Destroy +# passes 76/76 +# +#2005-10-24 +# fix objectRef_TraceHandler so that reading a property via an object reference using array syntax will call a PropertyRead function if defined. +# 1.0.8.0 now passes 75/76 +# +#2005-10-19 +# Command alias introduced by @next@ is now placed in the interfaces namespace. (was unnamespaced before) +# changed IFACE array names for level0 methods to be m-1 instead of just m. (now consistent with higher level m-X names) +# 1.0.8.0 (passes 74/76) +# tests now in own package +# usage: +# package require test::pattern +# test::p::list +# test::p::run ?nameglob? ?-version ? +# +#2005-09?-12 +# +# fixed standalone 'var' statement in method bodies so that no implicit variable declarations added to proc. +# fixed @next@ so that destination method resolved at interface compile time instead of call time +# fixed @next@ so that on Create, .. PatternMethod x overlays existing method produced by a previous .. PatternMethod x. +# (before, the overlay only occured when '.. Method' was used to override.) +# +# +# miscellaneous tidy-ups +# +# 1.0.7.8 (passes 71/73) +# +#2005-09-10 +# fix 'unknown' system such that unspecified 'unknown' handler represented by lack of (unknown) variable instead of empty string value +# this is so that a mixin with an unspecified 'unknown' handler will not undo a lowerlevel 'unknown' specificier. +# +#2005-09-07 +# bugfix indexed write to list property +# bugfix Variable default value +# 1.0.7.7 (passes 70/72) +# fails: +# arrayproperty.test - array-entire-reference +# properties.test - property_getter_filter_via_ObjectRef +# +#2005-04-22 +# basic fix to PatternPropertyRead dispatch code - updated tests (indexed case still not fixed!) +# +# 1.0.7.4 +# +#2004-11-05 +# basic PropertyRead implementation (non-indexed - no tests!) +# +#2004-08-22 +# object creation speedups - (pattern::internals::obj simplified/indirected) +# +#2004-08-17 +# indexed property setter fixes + tests +# meta::Create fixes - state preservation on overlay (correct constructor called, property defaults respect existing values) +# +#2004-08-16 +# PropertyUnset & PatternPropertyUnset metaMethods (filter method called on property unset) +# +#2004-08-15 +# reference syncing: ensure writes to properties always trigger traces on property references (+ tests) +# - i.e method that updates o_myProp var in >myObj will cause traces on [>myObj . myProp .] to trigger +# - also trigger on curried traces to indexed properties i.e list and array elements. +# - This feature presumably adds some overhead to all property writes - !todo - investigate desirability of mechanism to disable on specific properties. +# +# fix (+ tests) for ref to multiple indices on object i.e [>myObj key1 key2 .] +# +#2004-08-05 +# add PropertyWrite & PatternPropertyWrite metaMethods - (filter method called on property write) +# +# fix + add tests to support method & property of same name. (method precedence) +# +#2004-08-04 +# disallow attempt to use method reference as if it were a property (raise error instead of silently setting useless var) +# +# 1.0.7.1 +# use objectref array access to read properties even when some props unset; + test +# unset property using array access on object reference; + test +# +# +#2004-07-21 +# object reference changes - array property values appear as list value when accessed using upvared array. +# bugfixes + tests - properties containing lists (multidimensional access) +# +#1.0.7 +# +#2004-07-20 +# fix default property value append problem +# +#2004-07-17 +# add initial implementation of 'Unknown' and 'PatternUnknown' meta-methods +# ( +# +#2004-06-18 +# better cleanup on '>obj .. Destroy' - recursively destroy objects under parents subnamespaces. +# +#2004-06-05 +# change argsafety operator to be anything with leading - +# if standalone '-' then the dash itself is not added as a parameter, but if a string follows '-' +# i.e tkoption style; e.g -myoption ; then in addition to acting as an argsafety operator for the following arg, +# the entire dash-prefixed operator is also passed in as an argument. +# e.g >object . doStuff -window . +# will call the doStuff method with the 2 parameters -window . +# >object . doStuff - . +# will call doStuff with single parameter . +# >object . doStuff - -window . +# will result in a reference to the doStuff method with the argument -window 'curried' in. +# +#2004-05-19 +#1.0.6 +# fix so custom constructor code called. +# update Destroy metamethod to unset $self +# +#1.0.4 - 2004-04-22 +# bug fixes regarding method specialisation - added test +# +#------------------------------------------------------------ + +package provide pattern [namespace eval pattern {variable version; set version 1.2.4}] + + +namespace eval pattern::util { + + # Generally better to use 'package require $minver-' + # - this only gives us a different error + proc package_require_min {pkg minver} { + if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} { + package require $pkg + } else { + error "Package pattern requires package $pkg of at least version $minver. Available: $available" + } + } +} + +package require patterncmd 1.2.4- +package require metaface 1.2.4- ;#utility/system diagnostic commands (may be used by metaface lib etc) + + + +#package require cmdline +package require overtype + +#package require md5 ;#will be loaded if/when needed +#package require md4 +#package require uuid + + + + + +namespace eval pattern { + variable initialised 0 + + + if 0 { + if {![catch {package require twapi_base} ]} { + #twapi is a windows only package + #MUCH faster to load just twapi_base than full 'package require twapi' IFF using the modular twapi distribution with multiple separately loadable dlls. + # If available - windows seems to provide a fast uuid generator.. + #*IF* tcllibc is missing, then as at 2008-05 twapi::new_uuid is significantly faster than uuid::uuid generate ( e.g 19 usec vs 76thousand usec! on 2.4GHZ machine) + # (2018 update - 15-30usec vs ~200usec on core i9 @ ~2.6GHZ (time for a single call e.g time {pattern::new_uuid})) + interp alias {} ::pattern::new_uuid {} ::twapi::new_uuid -localok + } else { + #performance on freebsd seems not great, but adequate. (e.g 500usec on dualcore 1.6GHZ) + # (e.g 200usec 2018 corei9) + #(with or without tcllibc?) + #very first call is extremely slow though - 3.5seconds on 2018 corei9 + package require uuid + interp alias {} ::pattern::new_uuid {} ::uuid::uuid generate + } + #variable fastobj 0 ;#precalculated invocant ID in method body (instead of call time ) - removed for now - see pattern 1.2.1 (a premature optimisation which was hampering refactoring & advancement) + } + + +} + + + + + + +namespace eval p { + #this is also the interp alias namespace. (object commands created here , then renamed into place) + #the object aliases are named as incrementing integers.. !todo - consider uuids? + variable ID 0 + namespace eval internals {} + + + #!?? + #namespace export ?? + variable coroutine_instance 0 +} + +#------------------------------------------------------------------------------------- +#review - what are these for? +#note - this function is deliberately not namespaced +# - it begins with the letters 'proc' (as do the created aliases) - to aid in editor's auto indexing/mapping features +proc process_pattern_aliases {object args} { + set o [namespace tail $object] + interp alias {} process_patternmethod_$o {} [$object .. PatternMethod .] + interp alias {} process_method_$o {} [$object .. Method .] + interp alias {} process_constructor_$o {} [$object .. Constructor .] +} +#------------------------------------------------------------------------------------- + + + + +#!store all interface objects here? +namespace eval ::p::ifaces {} + + + +#K combinator - see http://wiki.tcl.tk/1923 +#proc ::p::K {x y} {set x} +#- not used - use inline K if desired i.e set x [lreplace $x[set x{}] $a $b blah] + + + + + + + + +proc ::p::internals::(VIOLATE) {_ID_ violation_script} { + #set out [::p::fixed_var_statements @IMPLICITDECLS@\n$violation_script] + set processed [dict create {*}[::p::predator::expand_var_statements $violation_script]] + + if {![dict get $processed explicitvars]} { + #no explicit var statements - we need the implicit ones + set self [set ::p::${_ID_}::(self)] + set IFID [lindex [set $self] 1 0 end] + #upvar ::p::${IFID}:: self_IFINFO + + + set varDecls {} + set vlist [array get ::p::${IFID}:: v,name,*] + set _k ""; set v "" + if {[llength $vlist]} { + append varDecls "upvar #0 " + foreach {_k v} $vlist { + append varDecls "::p::\${_ID_}::$v $v " + } + append varDecls "\n" + } + + #set violation_script [string map [::list @IMPLICITDECLS@ $varDecls] $out] + set violation_script $varDecls\n[dict get $processed body] + + #tidy up + unset processed varDecls self IFID _k v + } else { + set violation_script [dict get $processed body] + } + unset processed + + + + + #!todo - review (& document) exactly what context this script runs in and what vars/procs are/should be visible. + eval "unset violation_script;$violation_script" +} + + +proc ::p::internals::DestroyObjectsBelowNamespace {ns} { + #puts "\n##################\n#################### destroyObjectsBelowNamespace $ns\n" + + set nsparts [split [string trim [string map {:: :} $ns] :] :] + if { ! ( ([llength $nsparts] == 3) & ([lindex $nsparts 0] == "p") & ([lindex $nsparts end] eq "_ref") )} { + #ns not of form ::p::?::_ref + + foreach obj [info commands ${ns}::>*] { + #catch {::p::meta::Destroy $obj} + #puts ">>found object $obj below ns $ns - destroying $obj" + $obj .. Destroy + } + } + + #set traces [trace info variable ${ns}::-->PATTERN_ANCHOR] + #foreach tinfo $traces { + # trace remove variable ${ns}::-->PATTERN_ANCHOR {*}$tinfo + #} + #unset -nocomplain ${ns}::-->PATTERN_ANCHOR + + foreach sub [namespace children $ns] { + ::p::internals::DestroyObjectsBelowNamespace $sub + } +} + + + + +################################################# +################################################# +################################################# +################################################# +################################################# +################################################# +################################################# +################################################# +################################################# +################################################# + + + + + + + + + +proc ::p::get_new_object_id {} { + tailcall incr ::p::ID + #tailcall ::pattern::new_uuid +} + +#create a new minimal object - with no interfaces or patterns. + +#proc ::p::internals::new_object [list cmd {wrapped ""} [list OID [expr {-2}]]] {} +proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { + + #puts "-->new_object cmd:$cmd wrapped:$wrapped OID:$OID" + + if {$OID eq "-2"} { + set OID [::p::get_new_object_id] + #set OID [incr ::p::ID] ;#!todo - use uuids? (too slow?) (use uuids as configurable option?, pre-allocate a list of uuids?) + #set OID [pattern::new_uuid] + } + #if $wrapped provided it is assumed to be an existing namespace. + #if {[string length $wrapped]} { + # #??? + #} + + #sanity check - alias must not exist for this OID + if {[llength [interp alias {} ::p::$OID]]} { + error "Object alias '::p::$OID' already exists - cannot create new object with this id" + } + + #system 'varspaces' - + + #until we have a version of Tcl that doesn't have 'creative writing' scope issues - + # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. + # (see http://wiki.tcl.tk/1030 'Dangers of creative writing') + #set o_open 1 - every object is initially also an open interface (?) + #NOTE! comments within namespace eval slow it down. + namespace eval ::p::$OID { + #namespace ensemble create + namespace eval _ref {} + namespace eval _meta {} + namespace eval _iface { + variable o_usedby; + variable o_open 1; + array set o_usedby [list]; + variable o_varspace "" ; + variable o_varspaces [list]; + variable o_methods [dict create]; + variable o_properties [dict create]; + variable o_variables; + variable o_propertyunset_handlers; + set o_propertyunset_handlers [dict create] + } + } + + #set alias ::p::$OID + + #objectid alis default_method object_command wrapped_namespace + set INVOCANTDATA [list $OID ::p::$OID "" $cmd $wrapped] + + #MAP is a dict + set MAP [list invocantdata $INVOCANTDATA interfaces {level0 {} level0_default "" level1 {} level1_default ""} patterndata {patterndefaultmethod ""}] + + + + #NOTE 'interp alias' will prepend :: if chosen srccmd already exists as an alias token + #we've already checked that ::p::$OID doesn't pre-exist + # - so we know the return value of the [interp alias {} $alias {} ...] will be $alias + #interp alias {} ::p::$OID {} ::p::internals::predator $MAP + + + # _ID_ structure + set invocants_dict [dict create this [list $INVOCANTDATA] ] + #puts stdout "New _ID_structure: $interfaces_dict" + set _ID_ [dict create i $invocants_dict context ""] + + + interp alias {} ::p::$OID {} ::p::internals::predator $_ID_ + #rename the command into place - thus the alias & the command name no longer match! + rename ::p::$OID $cmd + + set ::p::${OID}::_meta::map $MAP + + # called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something + interp alias {} ::p::${OID}:: {} ::p::internals::no_default_method $_ID_ + + #set p2 [string map {> ?} $cmd] + #interp alias {} $p2 {} ::p::internals::alternative_predator $_ID_ + + + #trace add command $cmd delete "$cmd .. Destroy ;#" + #puts "@@@ trace add command $cmd rename [list $cmd .. Rename]" + + trace add command $cmd rename [list $cmd .. Rename] ;#will receive $oldname $newname "rename" + #trace add command $cmd rename [$cmd .. Rename .] ;#EXTREMELY slow. (but why?) + + #puts "@@@ trace added for $cmd -> '[trace info command $cmd]'" + + + #uplevel #0 "trace add command $cmd delete \"puts deleting$cmd ;#\"" + #trace add command $cmd delete "puts deleting$cmd ;#" + #puts stdout "trace add command $cmd delete \"puts deleting$cmd ;#\"" + + + #puts "--> new_object returning map $MAP" + return $MAP +} + + + + +#>x .. Create >y +# ".." is special case equivalent to "._." +# (whereas in theory it would be ".default.") +# "." is equivalent to ".default." is equivalent to ".default.default." (...) + +#>x ._. Create >y +#>x ._.default. Create >y ??? +# +# + +# create object using 'blah' as source interface-stack ? +#>x .blah. .. Create >y +#>x .blah,_. ._. Create .iStackDestination. >y + + + +# +# ">x .blah,_." is a reference(cast) to >x that contains only the iStacks in the order listed. i.e [list blah _] +# the 1st item, blah in this case becomes the 'default' iStack. +# +#>x .*. +# cast to object with all iStacks +# +#>x .*,!_. +# cast to object with all iStacks except _ +# +# --------------------- +#!todo - MultiMethod support via transient and persistent object conglomerations. Operators '&' & '@' +# - a persistent conglomeration will have an object id (OID) and thus associated namespace, whereas a transient one will not. +# +#eg1: >x & >y . some_multi_method arg arg +# this is a call to the MultiMethod 'some_multi_method' with 2 objects as the invocants. ('>x & >y' is a transient conglomeration of the two objects) +# No explicit 'invocation role' is specified in this call - so it gets the default role for multiple invocants: 'these' +# The invocant signature is thus {these 2} +# (the default invocation role for a standard call on a method with a single object is 'this' - with the associated signature {this 1}) +# Invocation roles can be specified in the call using the @ operator. +# e.g >x & >y @ points . some_multi_method arg arg +# The invocant signature for this is: {points 2} +# +#eg2: {*}[join $objects &] @ objects & >p @ plane . move $path +# This has the signature {objects n plane 1} where n depends on the length of the list $objects +# +# +# To get a persistent conglomeration we would need to get a 'reference' to the conglomeration. +# e.g set pointset [>x & >y .] +# We can now call multimethods on $pointset +# + + + + + + +#set ::p::internals::predator to a particular predatorversion (from a patternpredatorX package) +proc ::pattern::predatorversion {{ver ""}} { + variable active_predatorversion + set allowed_predatorversions {1 2} + set default_predatorversion [lindex $allowed_predatorversions end] ;#default to last in list of allowed_predatorversions + + if {![info exists active_predatorversion]} { + set first_time_set 1 + } else { + set first_time_set 0 + } + + if {$ver eq ""} { + #get version + if {$first_time_set} { + set active_predatorversions $default_predatorversion + } + return $active_predatorversion + } else { + #set version + if {$ver ni $allowed_predatorversions} { + error "Invalid attempt to set predatorversion - unknown value: $ver, try one of: $allowed_predatorversions" + } + + if {!$first_time_set} { + if {$active_predatorversion eq $ver} { + #puts stderr "Active predator version is already '$ver'" + #ok - nothing to do + return $active_predatorversion + } else { + package require patternpredator$ver 1.2.4- + if {![llength [info commands ::p::predator$ver]]} { + error "Unable to set predatorversion - command ::p::predator$ver not found" + } + rename ::p::internals::predator ::p::predator$active_predatorversion + } + } + package require patternpredator$ver 1.2.4- + if {![llength [info commands ::p::predator$ver]]} { + error "Unable to set predatorversion - command ::p::predator$ver not found" + } + + rename ::p::predator$ver ::p::internals::predator + set active_predatorversion $ver + + return $active_predatorversion + } +} +::pattern::predatorversion 2 + + + + + + + + + + + + +# >pattern has object ID 1 +# meta interface has object ID 0 +proc ::pattern::init args { + + if {[set ::pattern::initialised]} { + if {[llength $args]} { + #if callers want to avoid this error, they can do their own check of $::pattern::initialised + error "pattern package is already initialised. Unable to apply args: $args" + } else { + return 1 + } + } + + #this seems out of date. + # - where is PatternPropertyRead? + # - Object is obsolete + # - Coinjoin, Combine don't seem to exist + array set ::p::metaMethods { + Clone object + Conjoin object + Combine object + Create object + Destroy simple + Info simple + Object simple + PatternProperty simple + PatternPropertyWrite simple + PatternPropertyUnset simple + Property simple + PropertyWrite simple + PatternMethod simple + Method simple + PatternVariable simple + Variable simple + Digest simple + PatternUnknown simple + Unknown simple + } + array set ::p::metaProperties { + Properties object + Methods object + PatternProperties object + PatternMethods object + } + + + + + + #create metaface - IID = -1 - also OID = -1 + # all objects implement this special interface - accessed via the .. operator. + + + + + + set ::p::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface + + + #OID = 0 + ::p::internals::new_object ::p::ifaces::>null "" 0 + + #? null object has itself as level0 & level1 interfaces? + #set ::p::ifaces::>null [list [list 0 ::p::ifaces::>null item] [list [list 0] [list 0]] [list {} {}]] + + #null interface should always have 'usedby' members. It should never be extended. + array set ::p::0::_iface::o_usedby [list i-1 ::p::internals::>metaface i0 ::p::ifaces::>null i1 ::>pattern] ;#'usedby' array + set ::p::0::_iface::o_open 0 + + set ::p::0::_iface::o_constructor [list] + set ::p::0::_iface::o_variables [list] + set ::p::0::_iface::o_properties [dict create] + set ::p::0::_iface::o_methods [dict create] + set ::p::0::_iface::o_varspace "" + set ::p::0::_iface::o_varspaces [list] + array set ::p::0::_iface::o_definition [list] + set ::p::0::_iface::o_propertyunset_handlers [dict create] + + + + + ############################### + # OID = 1 + # >pattern + ############################### + ::p::internals::new_object ::>pattern "" 1 + + #set ::>pattern [list [list 1 ::>pattern item] [list [list 0] [list 0]]] + + + array set ::p::1::_iface::o_usedby [list] ;#'usedby' array + + set _self ::pattern + + #set IFID [::p::internals::new_interface 1] ;#level 0 interface usedby object 1 + #set IFID_1 [::p::internals::new_interface 1] ;#level 1 interface usedby object 1 + + + + #1)this object references its interfaces + #lappend ID $IFID $IFID_1 + #lset SELFMAP 1 0 $IFID + #lset SELFMAP 2 0 $IFID_1 + + + #set body [string map [::list @self@ ::>pattern @_self@ ::pattern @self_ID@ 0 @itemCmd@ item] $::p::internals::OBJECTCOMMAND] + #proc ::>pattern args $body + + + + + ####################################################################################### + #OID = 2 + # >ifinfo interface for accessing interfaces. + # + ::p::internals::new_object ::p::ifaces::>2 "" 2 ;#>ifinfo object + set ::p::2::_iface::o_constructor [list] + set ::p::2::_iface::o_variables [list] + set ::p::2::_iface::o_properties [dict create] + set ::p::2::_iface::o_methods [dict create] + set ::p::2::_iface::o_varspace "" + set ::p::2::_iface::o_varspaces [list] + array set ::p::2::_iface::o_definition [list] + set ::p::2::_iface::o_open 1 ;#open for extending + + ::p::ifaces::>2 .. AddInterface 2 + + #Manually create a minimal >ifinfo implementation using the same general pattern we use for all method implementations + #(bootstrap because we can't yet use metaface methods on it) + + + + proc ::p::2::_iface::isOpen.1 {_ID_} { + return $::p::2::_iface::o_open + } + interp alias {} ::p::2::_iface::isOpen {} ::p::2::_iface::isOpen.1 + + proc ::p::2::_iface::isClosed.1 {_ID_} { + return [expr {!$::p::2::_iface::o_open}] + } + interp alias {} ::p::2::_iface::isClosed {} ::p::2::_iface::isClosed.1 + + proc ::p::2::_iface::open.1 {_ID_} { + set ::p::2::_iface::o_open 1 + } + interp alias {} ::p::2::_iface::open {} ::p::2::_iface::open.1 + + proc ::p::2::_iface::close.1 {_ID_} { + set ::p::2::_iface::o_open 0 + } + interp alias {} ::p::2::_iface::close {} ::p::2::_iface::close.1 + + + #proc ::p::2::_iface::(GET)properties.1 {_ID_} { + # set ::p::2::_iface::o_properties + #} + #interp alias {} ::p::2::_iface::(GET)properties {} ::p::2::_iface::(GET)properties.1 + + #interp alias {} ::p::2::properties {} ::p::2::_iface::(GET)properties + + + #proc ::p::2::_iface::(GET)methods.1 {_ID_} { + # set ::p::2::_iface::o_methods + #} + #interp alias {} ::p::2::_iface::(GET)methods {} ::p::2::_iface::(GET)methods.1 + #interp alias {} ::p::2::methods {} ::p::2::_iface::(GET)methods + + + + + + #link from object to interface (which in this case are one and the same) + + #interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen [::p::ifaces::>2 --] + #interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed [::p::ifaces::>2 --] + #interp alias {} ::p::2::open {} ::p::2::_iface::open [::p::ifaces::>2 --] + #interp alias {} ::p::2::close {} ::p::2::_iface::close [::p::ifaces::>2 --] + + interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen + interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed + interp alias {} ::p::2::open {} ::p::2::_iface::open + interp alias {} ::p::2::close {} ::p::2::_iface::close + + + #namespace eval ::p::2 "namespace export $method" + + ####################################################################################### + + + + + + + set ::pattern::initialised 1 + + + ::p::internals::new_object ::p::>interface "" 3 + #create a convenience object on which to manipulate the >ifinfo interface + #set IF [::>pattern .. Create ::p::>interface] + set IF ::p::>interface + + + #!todo - put >ifinfo on a separate pStack so that end-user can more freely treat interfaces as objects? + # (or is forcing end user to add their own pStack/iStack ok .. ?) + # + ::p::>interface .. AddPatternInterface 2 ;# + + ::p::>interface .. PatternVarspace _iface + + ::p::>interface .. PatternProperty methods + ::p::>interface .. PatternPropertyRead methods {} { + varspace _iface + var {o_methods alias} + return $alias + } + ::p::>interface .. PatternProperty properties + ::p::>interface .. PatternPropertyRead properties {} { + varspace _iface + var o_properties + return $o_properties + } + ::p::>interface .. PatternProperty variables + + ::p::>interface .. PatternProperty varspaces + + ::p::>interface .. PatternProperty definition + + ::p::>interface .. Constructor {{usedbylist {}}} { + #var this + #set this @this@ + #set ns [$this .. Namespace] + #puts "-> creating ns ${ns}::_iface" + #namespace eval ${ns}::_iface {} + + varspace _iface + var o_constructor o_variables o_properties o_methods o_definition o_usedby o_varspace o_varspaces + + set o_constructor [list] + set o_variables [list] + set o_properties [dict create] + set o_methods [dict create] + set o_varspaces [list] + array set o_definition [list] + + foreach usedby $usedbylist { + set o_usedby(i$usedby) 1 + } + + + } + ::p::>interface .. PatternMethod isOpen {} { + varspace _iface + var o_open + + return $o_open + } + ::p::>interface .. PatternMethod isClosed {} { + varspace _iface + var o_open + + return [expr {!$o_open}] + } + ::p::>interface .. PatternMethod open {} { + varspace _iface + var o_open + set o_open 1 + } + ::p::>interface .. PatternMethod close {} { + varspace _iface + var o_open + set o_open 0 + } + ::p::>interface .. PatternMethod refCount {} { + varspace _iface + var o_usedby + return [array size o_usedby] + } + + set ::p::2::_iface::o_open 1 + + + + + uplevel #0 {pattern::util::package_require_min patternlib 1.2.4} + #uplevel #0 {package require patternlib} + return 1 +} + + + +proc ::p::merge_interface {old new} { + #puts stderr " ** ** ** merge_interface $old $new" + set ns_old ::p::$old + set ns_new ::p::$new + + upvar #0 ::p::${new}:: IFACE + upvar #0 ::p::${old}:: IFACEX + + if {![catch {set c_arglist $IFACEX(c,args)}]} { + #constructor + #for now.. just add newer constructor regardless of any existing one + #set IFACE(c,args) $IFACEX(c,args) + + #if {![info exists IFACE(c,args)]} { + # #target interface didn't have a constructor + # + #} else { + # # + #} + } + + + set methods [::list] + foreach nm [array names IFACEX m-1,name,*] { + lappend methods [lindex [split $nm ,] end] ;#use the method key-name not the value! (may have been overridden) + } + + #puts " *** merge interface $old -> $new ****merging-in methods: $methods " + + foreach method $methods { + if {![info exists IFACE(m-1,name,$method)]} { + #target interface doesn't yet have this method + + set THISNAME $method + + if {![string length [info command ${ns_new}::$method]]} { + + if {![set ::p::${old}::_iface::o_open]} { + #interp alias {} ${ns_new}::$method {} ${ns_old}::$method + #namespace eval $ns_new "namespace export [namespace tail $method]" + } else { + #wait to compile + } + + } else { + error "merge interface - command collision " + } + #set i 2 ??? + set i 1 + + } else { + #!todo - handle how? + #error "command $cmd already exists in interface $new" + + + set i [incr IFACE(m-1,chain,$method)] + + set THISNAME ___system___override_${method}_$i + + #move metadata using subindices for delegated methods + set IFACE(m-$i,name,$method) $IFACE(m-1,name,$method) + set IFACE(m-$i,iface,$method) $IFACE(m-1,iface,$method) + set IFACE(mp-$i,$method) $IFACE(mp-1,$method) + + set IFACE(m-$i,body,$method) $IFACE(m-1,body,$method) + set IFACE(m-$i,args,$method) $IFACE(m-1,args,$method) + + + #set next [::p::next_script $IFID0 $method] + if {![string length [info command ${ns_new}::$THISNAME]]} { + if {![set ::p::${old}::_iface::o_open]} { + interp alias {} ${ns_new}::$THISNAME {} ${ns_old}::$method + namespace eval $ns_new "namespace export $method" + } else { + #wait for compile + } + } else { + error "merge_interface - command collision " + } + + } + + array set IFACE [::list \ + m-1,chain,$method $i \ + m-1,body,$method $IFACEX(m-1,body,$method) \ + m-1,args,$method $IFACEX(m-1,args,$method) \ + m-1,name,$method $THISNAME \ + m-1,iface,$method $old \ + ] + + } + + + + + + #array set ${ns_new}:: [array get ${ns_old}::] + + + #!todo - review + #copy everything else across.. + + foreach {nm v} [array get IFACEX] { + #puts "-.- $nm" + if {([string first "m-1," $nm] != 0) && ($nm ne "usedby")} { + set IFACE($nm) $v + } + } + + #!todo -write a test + set ::p::${new}::_iface::o_open 1 + + #!todo - is this done also when iface compiled? + #namespace eval ::p::$new {namespace ensemble create} + + + #puts stderr "copy_interface $old $new" + + #assume that the (usedby) data is now obsolete + #???why? + #set ${ns_new}::(usedby) [::list] + + #leave ::(usedby) reference in place + + return +} + + + + +#detect attempt to treat a reference to a method as a property +proc ::p::internals::commandrefMisuse_TraceHandler {OID field args} { +#puts "commandrefMisuse_TraceHandler fired OID:$OID field:$field args:$args" + lassign [lrange $args end-2 end] vtraced vidx op + #NOTE! cannot rely on vtraced as it may have been upvared + + switch -- $op { + write { + error "$field is not a property" "property ref write failure for property $field (OID: $OID refvariable: [lindex $args 0])" + } + unset { + #!todo - monitor stat of Tcl bug# 1911919 - when/(if?) fixed - reinstate 'unset' trace + #trace add variable $traced {read write unset} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args] + + #!todo - don't use vtraced! + trace add variable $vtraced {read write unset array} [concat ::p::internals::commandrefMisuse_TraceHandler $OID $field $args] + + #pointless raising an error as "Any errors in unset traces are ignored" + #error "cannot unset. $field is a method not a property" + } + read { + error "$field is not a property (args $args)" "property ref read failure for property $field (OID: $OID refvariable: [lindex $args 0])" + } + array { + error "$field is not a property (args $args)" "property ref use as array failure for property $field (OID: $OID refvariable: [lindex $args 0])" + #error "unhandled operation in commandrefMisuse_TraceHandler - got op:$op expected read,write,unset. OID:$OID field:$field args:$args" + } + } + + return +} + + + + +#!todo - review calling-points for make_dispatcher.. probably being called unnecessarily at some points. +# +# The 'dispatcher' is an object instance's underlying object command. +# + +#proc ::p::make_dispatcher {obj ID IFID} { +# proc [string map {::> ::} $obj] {{methprop INFO} args} [string map [::list @IID@ $IFID @oid@ $ID] { +# ::p::@IID@ $methprop @oid@ {*}$args +# }] +# return +#} + + + + +################################################################################################################################################ +################################################################################################################################################ +################################################################################################################################################ + +#aliased from ::p::${OID}:: +# called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something +proc ::p::internals::no_default_method {_ID_ args} { + puts stderr "p::internals::no_default_method _ID_:'$_ID_' args:'$args'" + lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command wrapped + tailcall error "No default method on object $object_command. (To get or set, use: $object_command .. DefaultMethod ?methodname? or use PatternDefaultMethod)" +} + +#force 1 will extend an interface even if shared. (??? why is this necessary here?) +#if IID empty string - create the interface. +proc ::p::internals::expand_interface {IID {force 0}} { + #puts stdout ">>> expand_interface $IID [info level -1]<<<" + if {![string length $IID]} { + #return [::p::internals::new_interface] ;#new interface is by default open for extending (o_open = 1) + set iid [expr {$::p::ID + 1}] + ::p::>interface .. Create ::p::ifaces::>$iid + return $iid + } else { + if {[set ::p::${IID}::_iface::o_open]} { + #interface open for extending - shared or not! + return $IID + } + + if {[array size ::p::${IID}::_iface::o_usedby] > 1} { + #upvar #0 ::p::${IID}::_iface::o_usedby prev_usedby + + #oops.. shared interface. Copy before specialising it. + set prev_IID $IID + + #set IID [::p::internals::new_interface] + set IID [expr {$::p::ID + 1}] + ::p::>interface .. Create ::p::ifaces::>$IID + + ::p::internals::linkcopy_interface $prev_IID $IID + #assert: prev_usedby contains at least one other element. + } + + #whether copied or not - mark as open for extending. + set ::p::${IID}::_iface::o_open 1 + return $IID + } +} + +#params: old - old (shared) interface ID +# new - new interface ID +proc ::p::internals::linkcopy_interface {old new} { + #puts stderr " ** ** ** linkcopy_interface $old $new" + set ns_old ::p::${old}::_iface + set ns_new ::p::${new}::_iface + + + + foreach nsmethod [info commands ${ns_old}::*.1] { + #puts ">>> adding $nsmethod to iface $new" + set tail [namespace tail $nsmethod] + set method [string range $tail 0 end-2] ;#strip .1 + + if {![llength [info commands ${ns_new}::$method]]} { + + set oldhead [interp alias {} ${ns_old}::$method] ;#the 'head' of the cmdchain that it actually points to ie $method.$x where $x >=1 + + #link from new interface namespace to existing one. + #(we assume that since ${ns_new}::$method didn't exist, that all the $method.$x chain slots are empty too...) + #!todo? verify? + #- actual link is chainslot to chainslot + interp alias {} ${ns_new}::$method.1 {} $oldhead + + #!todo - review. Shouldn't we be linking entire chain, not just creating a single .1 pointer to the old head? + + + #chainhead pointer within new interface + interp alias {} ${ns_new}::$method {} ${ns_new}::$method.1 + + namespace eval $ns_new "namespace export $method" + + #if {[string range $method 0 4] ni {(GET) (SET) (UNSE (CONS }} { + # lappend ${ns_new}::o_methods $method + #} + } else { + if {$method eq "(VIOLATE)"} { + #ignore for now + #!todo + continue + } + + #!todo - handle how? + #error "command $cmd already exists in interface $new" + + #warning - existing chainslot will be completely shadowed by linked method. + # - existing one becomes unreachable. #!todo review!? + + + error "linkcopy_interface $old -> $new - chainslot shadowing not implemented (method $method already exists on target interface $new)" + + } + } + + + #foreach propinf [set ${ns_old}::o_properties] { + # lassign $propinf prop _default + # #interp alias {} ${ns_new}::(GET)$prop {} ::p::predator::getprop $prop + # #interp alias {} ${ns_new}::(SET)$prop {} ::p::predator::setprop $prop + # lappend ${ns_new}::o_properties $propinf + #} + + + set ${ns_new}::o_variables [set ${ns_old}::o_variables] + set ${ns_new}::o_properties [set ${ns_old}::o_properties] + set ${ns_new}::o_methods [set ${ns_old}::o_methods] + set ${ns_new}::o_constructor [set ${ns_old}::o_constructor] + + + set ::p::${old}::_iface::o_usedby(i$new) linkcopy + + + #obsolete.? + array set ::p::${new}:: [array get ::p::${old}:: ] + + + + #!todo - is this done also when iface compiled? + #namespace eval ::p::${new}::_iface {namespace ensemble create} + + + #puts stderr "copy_interface $old $new" + + #assume that the (usedby) data is now obsolete + #???why? + #set ${ns_new}::(usedby) [::list] + + #leave ::(usedby) reference in place for caller to change as appropriate - 'copy' + + return +} +################################################################################################################################################ +################################################################################################################################################ +################################################################################################################################################ + +pattern::init + +return $::pattern::version diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm new file mode 100644 index 00000000..ca061a7c --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm @@ -0,0 +1,645 @@ +package provide patterncmd [namespace eval patterncmd { + variable version + + set version 1.2.4 +}] + + +namespace eval pattern { + variable idCounter 1 ;#used by pattern::uniqueKey + + namespace eval cmd { + namespace eval util { + package require overtype + variable colwidths_lib [dict create] + variable colwidths_lib_default 15 + + dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] + dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] + dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] + dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] + + proc colhead {type args} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname [string totitle $colname] {*}$args]" + } + return $line + } + proc colbreak {type} { + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + set line "" + foreach colname [dict keys $colwidths] { + append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" + } + return $line + } + proc col {type col val args} { + # args -head bool -tail bool ? + #---------------------------------------------------------------------------- + set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] + dict set default -backchar "" + dict set default -headchar "" + dict set default -tailchar "" + dict set default -headoverridechar "" + dict set default -tailoverridechar "" + dict set default -justify "left" + if {([llength $args] % 2) != 0} { + error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set backchar [dict get $opts -backchar] + set headchar [dict get $opts -headchar] + set tailchar [dict get $opts -tailchar] + set headoverridechar [dict get $opts -headoverridechar] + set tailoverridechar [dict get $opts -tailoverridechar] + set justify [dict get $opts -justify] + #---------------------------------------------------------------------------- + + + + upvar #0 ::pattern::cmd::util::colwidths_$type colwidths + #calculate headwidths + set headwidth 0 + set tailwidth 0 + foreach {key def} $colwidths { + set thisheadlen [string length [dict get $def head]] + if {$thisheadlen > $headwidth} { + set headwidth $thisheadlen + } + set thistaillen [string length [dict get $def tail]] + if {$thistaillen > $tailwidth} { + set tailwidth $thistaillen + } + } + + + set spec [dict get $colwidths $col] + if {[string length $backchar]} { + set ch $backchar + } else { + set ch [dict get $spec ch] + } + set num [dict get $spec num] + set headchar [dict get $spec head] + set tailchar [dict get $spec tail] + + if {[string length $headchar]} { + set headchar $headchar + } + if {[string length $tailchar]} { + set tailchar $tailchar + } + #overrides only apply if the head/tail has a length + if {[string length $headchar]} { + if {[string length $headoverridechar]} { + set headchar $headoverridechar + } + } + if {[string length $tailchar]} { + if {[string length $tailoverridechar]} { + set tailchar $tailoverridechar + } + } + set head [string repeat $headchar $headwidth] + set tail [string repeat $tailchar $tailwidth] + + set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] + if {$justify eq "left"} { + set left_done [overtype::left $base "$head$val"] + return [overtype::right $left_done "$tail"] + } elseif {$justify in {centre center}} { + set mid_done [overtype::centre $base $val] + set left_mid_done [overtype::left $mid_done $head] + return [overtype::right $left_mid_done $tail] + } else { + set right_done [overtype::right $base "$val$tail"] + return [overtype::left $right_done $head] + } + + } + + } + } + +} + +#package require pattern + +proc ::pattern::libs {} { + set libs [list \ + pattern {-type core -note "alternative:pattern2"}\ + pattern2 {-type core -note "alternative:pattern"}\ + patterncmd {-type core}\ + metaface {-type core}\ + patternpredator2 {-type core}\ + patterndispatcher {-type core}\ + patternlib {-type core}\ + patterncipher {-type optional -note optional}\ + ] + + + + package require overtype + set result "" + + append result "[cmd::util::colbreak lib]\n" + append result "[cmd::util::colhead lib -justify centre]\n" + append result "[cmd::util::colbreak lib]\n" + foreach libname [dict keys $libs] { + set libinfo [dict get $libs $libname] + + append result [cmd::util::col lib library $libname] + if {[catch [list package present $libname] ver]} { + append result [cmd::util::col lib version "N/A"] + } else { + append result [cmd::util::col lib version $ver] + } + append result [cmd::util::col lib type [dict get $libinfo -type]] + + if {[dict exists $libinfo -note]} { + set note [dict get $libinfo -note] + } else { + set note "" + } + append result [cmd::util::col lib note $note] + append result "\n" + } + append result "[cmd::util::colbreak lib]\n" + return $result +} + +proc ::pattern::record {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply { + {index rec args} + { + if {[llength $args] == 0} { + return [lindex $rec $index] + } + if {[llength $args] == 1} { + return [lreplace $rec $index $index [lindex $args 0]] + } + error "Invalid number of arguments." + } + + }] + + set map {} + foreach field $fields { + dict set map $field [linsert $accessor end [incr index]] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} +proc ::pattern::record2 {recname fields} { + if {[uplevel 1 [list namespace which $recname]] ne ""} { + error "(pattern::record) Can't create command '$recname': A command of that name already exists" + } + + set index -1 + set accessor [list ::apply] + + set template { + {rec args} + { + if {[llength $args] == 0} { + return [lindex $rec %idx%] + } + if {[llength $args] == 1} { + return [lreplace $rec %idx% %idx% [lindex $args 0]] + } + error "Invalid number of arguments." + } + } + + set map {} + foreach field $fields { + set body [string map [list %idx% [incr index]] $template] + dict set map $field [list ::apply $body] + } + uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] +} + +proc ::argstest {args} { + package require cmdline + +} + +proc ::pattern::objects {} { + set result [::list] + + foreach ns [namespace children ::pp] { + #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] + set ch [namespace tail $ns] + if {[string range $ch 0 2] eq "Obj"} { + set OID [string range $ch 3 end] ;#OID need not be digits (!?) + lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] + } + } + + + + + return $result +} + + + +proc ::pattern::name {num} { + #!todo - fix + #set ::p::${num}::(self) + + lassign [interp alias {} ::p::$num] _predator info + if {![string length $_predator$info]} { + error "No object found for num:$num (no interp alias for ::p::$num)" + } + set invocants [dict get $info i] + set invocants_with_role_this [dict get $invocants this] + set invocant_this [lindex $invocants_with_role_this 0] + + + #lassign $invocant_this id info + #set map [dict get $info map] + #set fields [lindex $map 0] + lassign $invocant_this _id _ns _defaultmethod name _etc + return $name +} + + +proc ::pattern::with {cmd script} { + foreach c [info commands ::p::-1::*] { + interp alias {} [namespace tail $c] {} $c $cmd + } + interp alias {} . {} $cmd . + interp alias {} .. {} $cmd .. + + return [uplevel 1 $script] +} + + + + + +#system diagnostics etc + +proc ::pattern::varspace_list {IID} { + namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables + + set varspaces [list] + dict for {vname vdef} $o_variables { + set vs [dict get $vdef varspace] + if {$vs ni $varspaces} { + lappend varspaces $vs + } + } + if {$o_varspace ni $varspaces} { + lappend varspaces $o_varspace + } + return $varspaces +} + +proc ::pattern::check_interfaces {} { + foreach ns [namespace children ::p] { + set IID [namespace tail $ns] + if {[string is digit $IID]} { + foreach ref [array names ${ns}::_iface::o_usedby] { + set OID [string range $ref 1 end] + if {![namespace exists ::p::${OID}::_iface]} { + puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" + } else { + puts -nonewline stdout . + } + + + #if {![info exists ::p::${OID}::(self)]} { + # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" + #} + } + } + } + puts -nonewline stdout "\r\n" +} + + +#from: http://wiki.tcl.tk/8766 (Introspection on aliases) +#usedby: metaface-1.1.6+ +#required because aliases can be renamed. +#A renamed alias will still return it's target with 'interp alias {} oldname' +# - so given newname - we require which_alias to return the same info. + proc ::pattern::which_alias {cmd} { + uplevel 1 [list ::trace add execution $cmd enterstep ::error] + catch {uplevel 1 $cmd} res + uplevel 1 [list ::trace remove execution $cmd enterstep ::error] + #puts stdout "which_alias $cmd returning '$res'" + return $res + } +# [info args] like proc following an alias recursivly until it reaches +# the proc it originates from or cannot determine it. +# accounts for default parameters set by interp alias +# + + + +proc ::pattern::aliasargs {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info args $cmd] + # strip off the interp set default args + return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } + } +proc ::pattern::aliasbody {cmd} { + set orig $cmd + + set defaultargs [list] + + # loop until error or return occurs + while {1} { + # is it a proc already? + if {[string equal [info procs $cmd] $cmd]} { + set result [info body $cmd] + # strip off the interp set default args + return $result + #return [lrange $result [llength $defaultargs] end] + } + # is it a built in or extension command we can get no args for? + if {![string equal [info commands $cmd] $cmd]} { + error "\"$orig\" isn't a procedure" + } + + # catch bogus cmd names + if {[lsearch [interp aliases {}] $cmd]==-1} { + if {[catch {::pattern::which_alias $cmd} alias]} { + error "\"$orig\" isn't a procedure or alias or command" + } + #set cmd [lindex $alias 0] + if {[llength $alias]>1} { + set cmd [lindex $alias 0] + set defaultargs [concat [lrange $alias 1 end] $defaultargs] + } else { + set cmd $alias + } + } else { + + if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { + # check if it is aliased in from another interpreter + if {[catch {interp target {} $cmd} msg]} { + error "Cannot resolve \"$orig\", alias leads to another interpreter." + } + if {$msg != {} } { + error "Not recursing into slave interpreter \"$msg\".\ + \"$orig\" could not be resolved." + } + # check if defaults are set for the alias + if {[llength $cmdargs]>1} { + set cmd [lindex $cmdargs 0] + set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] + } else { + set cmd $cmdargs + } + } + } + } + } + + + + + +proc ::pattern::uniqueKey2 {} { + #!todo - something else?? + return [clock seconds]-[incr ::pattern::idCounter] +} + +#used by patternlib package +proc ::pattern::uniqueKey {} { + return [incr ::pattern::idCounter] + #uuid with tcllibc is about 30us compared with 2us + # for large datasets, e.g about 100K inserts this would be pretty noticable! + #!todo - uuid pool with background thread to repopulate when idle? + #return [uuid::uuid generate] +} + + + +#------------------------------------------------------------------------------------------------------------------------- + +proc ::pattern::test1 {} { + set msg "OK" + + puts stderr "next line should say:'--- saystuff:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternMethod saystuff args { + puts stderr "--- saystuff: $args" + } + ::>thing .. Create ::>jjj + + ::>jjj . saystuff $msg + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test2 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. PatternProperty stuff $msg + + ::>thing .. Create ::>jjj + + puts stderr "--- property 'stuff' value:[::>jjj . stuff]" + ::>jjj .. Destroy + ::>thing .. Destroy +} + +proc ::pattern::test3 {} { + set msg "OK" + + puts stderr "next line should say:'--- property 'stuff' value:$msg" + ::>pattern .. Create ::>thing + + ::>thing .. Property stuff $msg + + puts stderr "--- property 'stuff' value:[::>thing . stuff]" + ::>thing .. Destroy +} + +#--------------------------------- +#unknown/obsolete + + + + + + + + +#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} +if {0} { + proc ::p::internals::new_interface {{usedbylist {}}} { + set OID [incr ::p::ID] + ::p::internals::new_object ::p::ifaces::>$OID "" $OID + puts "obsolete >> new_interface created object $OID" + foreach usedby $usedbylist { + set ::p::${OID}::_iface::o_usedby(i$usedby) 1 + } + set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) + #NOTE - o_varspace is only the default varspace for when new methods/properties are added. + # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. + + set ::p::${OID}::_iface::o_constructor [list] + set ::p::${OID}::_iface::o_variables [list] + set ::p::${OID}::_iface::o_properties [dict create] + set ::p::${OID}::_iface::o_methods [dict create] + array set ::p::${OID}::_iface::o_definition [list] + set ::p::${OID}::_iface::o_open 1 ;#open for extending + return $OID + } + + + #temporary way to get OID - assumes single 'this' invocant + #!todo - make generic. + proc ::pattern::get_oid {_ID_} { + #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" + return [lindex [dict get $_ID_ i this] 0 0] + + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + #set role_members [dict get $invocants this] + ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. + #set this_invocant [lindex [dict get $_ID_ i this] 0] ; + #lassign $this_invocant OID this_info + # + #return $OID + } + + #compile the uncompiled level1 interface + #assert: no more than one uncompiled interface present at level1 + proc ::p::meta::PatternCompile {self} { + ???? + + upvar #0 $self SELFMAP + set ID [lindex $SELFMAP 0 0] + + set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces + + set iid -1 + foreach i $patterns { + if {[set ::p::${i}::_iface::o_open]} { + set iid $i ;#found it + break + } + } + + if {$iid > -1} { + #!todo + + ::p::compile_interface $iid + set ::p::${iid}::_iface::o_open 0 + } else { + #no uncompiled interface present at level 1. Do nothing. + return + } + } + + + proc ::p::meta::Def {self} { + error ::p::meta::Def + + upvar #0 $self SELFMAP + set self_ID [lindex $SELFMAP 0 0] + set IFID [lindex $SELFMAP 1 0 end] + + set maxc1 0 + set maxc2 0 + + set arrName ::p::${IFID}:: + + upvar #0 $arrName state + + array set methods {} + + foreach nm [array names state] { + if {[regexp {^m-1,name,(.+)} $nm _match mname]} { + set methods($mname) [set state($nm)] + + if {[string length $mname] > $maxc1} { + set maxc1 [string length $mname] + } + if {[string length [set state($nm)]] > $maxc2} { + set maxc2 [string length [set state($nm)]] + } + } + } + set bg1 [string repeat " " [expr {$maxc1 + 2}]] + set bg2 [string repeat " " [expr {$maxc2 + 2}]] + + + set r {} + foreach nm [lsort -dictionary [array names methods]] { + set arglist $state(m-1,args,$nm) + append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" + } + return $r + } + + + +} \ No newline at end of file diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/patternlib-1.2.6.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/patternlib-1.2.6.tm new file mode 100644 index 00000000..bd4b3e59 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/patternlib-1.2.6.tm @@ -0,0 +1,2590 @@ +#JMN 2004 +#public domain + + +package provide patternlib [namespace eval patternlib { + + variable version + set version 1.2.6 +}] + + + +#Change History +#------------------------------------------------------------------------------- +#2022-05 +# added . search and . itemKeys methods to >collection to enable lookups by value +#2021-09 +# Add >keyvalprotector - an object to overload various collection methods such as 'remove' to stop deletion of specific items. +# +#2006-05 +# deprecate 'del' in favour of 'remove' - 'del' still there but delegated to 'remove'. todo - emit deprecation warnings. +# +#2005-04 +# remove 'name' method - incorporate indexed retrieval into 'names' method +# !todo? - adjust key/keys methods for consistency? +# +#2004-10 +# initial key aliases support +# fix negative index support on some methods e.g remove +#2004-08 +# separated >collection predicate methods out onto separate 'mixin' object >predicatedCollection +# added $posn $result variables to predicate methods, changed varnames from $k $v to $key $value +# +#2004-06-05 +# added 'sort' method to sort on values. +# fixed 'keySort' method to accept multiple sort options +# added predicate methods 'all' 'allKeys' 'collectAll' +#2004-06-01 +# '>collection . names' method now accepts optional 'glob' parameter to filter result +#2004-05-19 +#fix '>collection . clear' method so consecutive calls don't raise an error +#------------------------------------------------------------------------------- + +namespace eval ::patternlib::util { + proc package_require_min {pkg minver} { + if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} { + package require $pkg + } else { + error "Package pattern requires package $pkg of at least version $minver. Available: $available" + } + } + + #bloom filter experiment https://wiki.tcl-lang.org/page/A+Simple+Bloom+Filter + # k-hashes + # m-bits + # n-elements + # optimal value of k: (m/n)ln(2) + #proc bloom_optimalNumHashes {capacity_n bitsize_m} { + # expr { round((double($bitsize_m) / $capacity_n) * log(2))} + #} + #proc bloom_optimalNumBits {capacity fpp} { + # expr {entier(-$capacity * log($fpp) / (log(2) * log(2)))} + #} + +} +::patternlib::util::package_require_min pattern 1.2.4 +#package require pattern +::pattern::init ;# initialises (if not already) + + +namespace eval ::patternlib {namespace export {[a-z]*} + namespace export {[>]*} + + variable keyCounter 0 ;#form part of unique keys for collections when items added without any key specified + proc uniqueKey {} { + return [incr ::patternlib::keyCounter] + } + +#!todo - multidimensional collection +# - o_list as nested list +# - o_array with compound keys(?) how will we unambiguously delimit dimensions in a concatenated key? +# - perhaps a key is always a list length n where n is the number of dimensions? +# - therefore we'll need an extra level of nesting for the current base case n=1 +# +# - how about a nested dict for each key-structure (o_list & o_array) ? + +#COLLECTION +# +#!todo? - consider putting the actual array & list vars in the objects namespace, and using the instancevars to hold their names +# - consider array-style access using traced var named same as collection. +# would this defeat the purpose ? if it was faster, would users always use array syntax in preference.. in which case they may as well just use arrays..? +#!todo - add boolean property to force unique values as well as keys + + +#::pattern::create >collection + + + + +::>pattern .. Create >collection +set COL >collection +#process_pattern_aliases [namespace origin >collection] +#process_pattern_aliases ::patternlib::>collection +$COL .. Property version 1.0 +$COL .. PatternDefaultMethod item + +set PV [$COL .. PatternVariable .] + +$PV o_data +#$PV o_array +#$PV o_list +$PV o_alias +$PV this + +#for invert method +$PV o_dupes 0 + + +$COL .. PatternProperty bgEnum + + +#PV o_ns + +$PV m_i_filteredCollection + +#set ID [lindex [set >collection] 0 0] ;#context ID +#set IID [lindex [set >collection] 1 0] ;#level 1 base-interface ID + +$COL .. Constructor {args} { + var o_data m_i_filteredCollection o_count o_bgEnum + + var this + set this @this@ + + set m_i_filteredCollection 0 + if {![llength $args]} { + set o_data [dict create] + #array set o_array [list] + #set o_list [list] + set o_count 0 + } elseif {[llength $args] == 1} { + set o_data [dict create] + set pairs [lindex $args 0] + if {[llength $pairs] % 2} { + error "patternllib::>collection - if an argument given to constructor, it must have an even number of elements. Bad args: $args" + } + set keys_seen [list] + foreach key [dict keys $pairs] { + if {[string is integer -strict $key] } { + error ">collection key must be non-integer. Bad key: $key. No items added." + } + if {$key in $keys_seen} { + error "key '$key' already exists in this collection. No items added." + } + lappend keys_seen $key + } + unset keys_seen + #rely on dict ordering guarantees (post 8.5? preserves order?) + set o_data [dict merge $o_data[set o_data {}] $pairs] + set o_count [dict size $o_data] + } else { + error "patternlib::>collection constructor did not understand arguments supplied. Try a dict as a single argument." + } + array set o_alias [list] + + array set o_bgEnum [list] + @next@ +} +#comment block snipped from collection Constructor + #--------------------------------------------- + #set o_selfID [lindex [set $o_this] 0] ;#object id always available in methods as $_ID_ anyway + # + #### OBSOLETE - left as example of an approach + #make count property traceable (e.g so property ref can be bound to Tk widgets) + #!todo - manually update o_count in relevant methods faster?? + # should avoid trace calls for addList methods, shuffle etc + # + #set handler ::p::${_ID_}::___count_TraceHandler + #proc $handler {_ID_ vname vidx op} { + # #foreach {vname vidx op} [lrange $args end-2 end] {break} + # #! we shouldn't trust this vname - it may be that we are being accessed via upvar so it is a different name + # + # #this is only a 'write' handler + # set ::p::[lindex ${_ID_} 0 0]::o_count [llength [set ::p::[lindex ${_ID_} 0 0]::o_list]] + # return + #} + #trace add variable o_list {write} [list $handler $_ID_] + #### + # + # + #puts "--->collection constructor id: $_ID_" + + + + +set PM [$COL .. PatternMethod .] + + +#!review - why do we need the count method as well as the property? +#if needed - document why. +# read traces on count property can be bypassed by method call... shouldn't we avoid that? +#2018 - in theory write traces on the . count property are very useful from an application-writer's perpective. +# +$COL .. PatternMethod count {} { + #we don't require any instance vars to be upvar'ed - argless [var] stops them automatically being added. + #we directly refer to the ::O:: var if only accessing a few times rather than upvar'ing. + var o_data + dict size $o_data +} + +$COL .. PatternProperty count +$COL .. PatternPropertyWrite count {_val} { + var + error "count property is read-only" +} + +$COL .. PatternPropertyUnset count {} { + var +} ;#cannot raise error's in unset trace handlers - simply fail to unset silently + +$COL .. PatternMethod isEmpty {} { + #var o_list + #return [expr {[llength $o_list] == 0}] + var o_data + expr {[dict size $o_data] == 0} +} + +$COL .. PatternProperty inverted 0 + + + +###### +# item +###### +#defaults to fifo when no idx supplied (same as 'pair' method). !review? is lifo more logical/intuitive/useful? +# i.e [>obj . item] returns the 1st element in the list +#[>obj . item -1] returns the last element (equiv to "end" keyword used by Tcl list commands) +#[>obj . item -2] returns 2nd last element (equiv to "end-1") + + +$COL .. PatternMethod item {{idx 0}} { + #with pattern::0::$OID access.. was measured faster than item2 : approx 110us vs 140us for 26element collection accessed via string (time {>col $key} 10000) + # (still at least 20 times slower than a plain array... at <5us) + var o_data o_alias + + #!todo - review 'string is digit' vs 'string is integer' ?? + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set keys [dict keys $o_data] + if {[catch {dict get $o_data [lindex $keys $idx]} result]} { + var this + error "no such index : '$idx' in collection: $this" + } else { + return $result + } + } else { + if {[catch {dict get $o_data $idx} result]} { + if {[catch {set o_alias($idx)} nextIdx ]} { + var this + error "no such index: '$idx' in collection: $this" + } else { + #try again + #return $o_array($nextIdx) + #tailcall? + #item $_ID_ $nextIdx + #puts stdout "\n\n\n !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! about to call tailcall item $_ID_ $nextIdx \n\n\n" + tailcall item $_ID_ $nextIdx + } + } else { + return $result + } + } +} + + + +if {0} { +#leave this here for comparison. +$COL .. PatternMethod item2 {{idx 0}} { + var o_array o_list o_alias this + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + + if {[catch {set o_array([lindex $o_list $idx])} result]} { + error "no such index : '$idx' in collection: $this" + } else { + return $result + } + } else { + if {[catch {set o_array($idx)} result]} { + + if {[catch {set o_alias($idx)} nextIdx ]} { + error "no such index: '$idx' in collection: $this" + } else { + #try again + #return $o_array($nextIdx) + item $_ID_ $nextIdx + } + } else { + return $result + } + } + +} +} + +#simple no-frills access for speed.. (timed at 43us vs 63us for item (depending on dispatch method!)) +$COL .. PatternMethod itemNamed {idx} { + var o_data + dict get $o_data $idx +} +$COL .. PatternMethod in {idx} { + var o_data + dict get $o_data $idx +} + +$COL .. PatternMethod itemAt {idx} { + var o_data + dict get $o_data [lindex [dict keys $o_data] $idx] +} + +$COL .. PatternMethod replace {idx val} { + var o_data o_alias this + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + + if {[catch {dict set o_data [lindex [dict keys $o_data] $idx] $val}]} { + error "no such index: '$idx' in collection: $this" + } else { + return $val + } + } else { + if {[catch {dict set o_data $idx $val}]} { + if {[catch {set o_alias($idx)} nextIdx ]} { + error "no such index: '$idx' in collection: $this" + } else { + #try again + tailcall replace $_ID_ $nextIdx $val + } + + } else { + return $val + } + } +} + +#if the supplied index is an alias, return the underlying key; else return the index supplied. +$COL .. PatternMethod realKey {idx} { + var o_alias + + if {[catch {set o_alias($idx)} key]} { + return $idx + } else { + return $key + } +} + +#note alias feature is possibly ill-considered. +#if we delete an item - should we delete corresponding alias? If not - we then would need to allow adding under an alias only if the corresponding key is missing. +$COL .. PatternMethod alias {newAlias existingKeyOrAlias} { + var o_alias + + #set existingKey [realKey $_ID_ $existingKeyOrAlias] + #alias to the supplied KeyOrAlias - not the underlying key + + if {[string is integer -strict $newAlias]} { + error "collection key alias cannot be integer" + } + + if {[string length $existingKeyOrAlias]} { + set o_alias($newAlias) $existingKeyOrAlias + } else { + unset o_alias($newAlias) + } +} +$COL .. PatternMethod aliases {{key ""}} { + var o_alias + + if {[string length $key]} { + set result [list] + #lsearch -stride? + foreach {n v} [array get o_alias] { + if {$v eq $key} { + lappend result $n $v + } + } + + return $result + } else { + return [array get o_alias] + } +} + +#'pop' & 'unshift' methods !todo - optimize so lsearch not called when numerical idx/posn already supplied + +#default to removing item from the end, otherwise from supplied index (position or key) +#!todo - accept alias indices +#!todo - review.. should any corresponding alias be destroyed when the corresponding item is popped (or removed in any way?) +#!todo - review.. for performance.. shouldn't pop NOT accept an index? +#if we need to pop from other than the end.. this could be a separate function. Do other langs use pop with an index?? +$COL .. PatternMethod pop {{idx ""}} { + var o_data o_count + + if {$idx eq ""} { + set key [lindex [dict keys $o_data] end] + } else { + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + } + set posn [lsearch -exact [dict keys $o_data] $key] + + if {($posn >= 0) && ($posn < [dict size $o_data])} { + set result [dict get $o_data $key] + dict unset o_data $key + set o_count [dict size $o_data] + return $result + } else { + error "no such index: '$idx'" + } +} +$COL .. PatternMethod poppair {} { + var o_data o_count + set key [lindex [dict keys $o_data] end] + set val [dict get $o_data $key] + dict unset o_data $key + set o_count [dict size $o_data] + return [list $key $val] +} + + + +#!todo - add 'push' method... (basically specialized versions of 'add') +#push - add at end (effectively an alias for add) +#shift - add at start ???bad name? this is completely at odds with for example the common Perl shift function, which returns and removes the first element of an array. +#add - add at end + +#ordered +$COL .. PatternMethod items {} { + var o_data + + dict values $o_data +} + + + + +#### +#pair +#### +#fifo-style accesss when no idx supplied (likewise with 'add' method) +$COL .. PatternMethod pair {{idx 0}} { + var o_data + + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + + if {[catch {dict get $o_data $key} val]} { + error "no such index: '$idx'" + } else { + return [list $key $val] + } +} +$COL .. PatternMethod pairs {} { + var o_data + set o_data +} + +$COL .. PatternMethod get {} { + var o_data + set o_data +} +#todo - fix >pattern so that methods don't collide with builtins +#may require change to use oo - or copy 'my' mechanism to call own methods +$COL .. PatternMethod Info {} { + var o_data + return [dict info $o_data] +} +#2006-05-21.. args to add really should be in key, value order? +# - this the natural order in array-like lists +# - however.. key should be optional. + +$COL .. PatternMethod add {val args} { + #(using args instead of {key ""} enables use of empty string as a key ) + + var o_data o_alias o_count this + + if {![llength $args]} { + set key "_[::patternlib::uniqueKey]_" + } else { + #!todo - could we handle multiple val,key pairs without impacting performance of the common case? + if {[llength $args] > 1} { + error "add method expected 'val' and optional 'key' - got: $val $args" + + } + + set key [lindex $args 0] + if {[string is integer -strict $key]} { + error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + } + + if {[dict exists $o_data $key]} { + #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" + error "key '$key' already exists in collection $this" + } + if {[info exists o_alias($key)]} { + if {[dict exists $o_data $o_alias($key)]} { + #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias + error "key '$key' already exists as an alias for $o_alias($key) in collection $this" + } + } + + dict set o_data $key $val + + + set posn $o_count + incr o_count + + return $posn +} + + +#should the 'stack' methods such as shift,push,pop,peek actually be on a separate interface? +#what then of methods like 'count' which apply equally well to collections and stacks? + +#Alias for 'add' - is there a way to alias this to add implementation with zero overhead?? +$COL .. PatternMethod push {val args} { + #(using args instead of {key ""} enables use of empty string as a key ) + + var o_data o_alias o_count this + + if {![llength $args]} { + set key "_[::patternlib::uniqueKey]_" + } else { + #!todo - could we handle multiple val,key pairs without impacting performance of the common case? + if {[llength $args] > 1} { + error "add method expected 'val' and optional 'key' - got: $val $args" + + } + + set key [lindex $args 0] + if {[string is integer -strict $key]} { + error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + } + + if {[dict exists $o_data $key]} { + #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" + error "key '$key' already exists in collection $this" + } + if {[info exists o_alias($key)]} { + if {[dict exists $o_data $o_alias($key)]} { + #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias + error "key '$key' already exists as an alias for $o_alias($key) in collection $this" + } + } + + dict set o_data $key $val + + + set posn $o_count + incr o_count + + return $posn +} + + +#shift/unshift - roughly analogous to those found in Perl & PHP +#unshift adds 1 or more values to the beginning of the collection. +$COL .. PatternMethod unshift {values {keys ""}} { + var o_data o_count + + if {![llength $keys]} { + for {set i 0} {$i < [llength $values]} {incr i} { + lappend keys "_[::patternlib::uniqueKey]_" + } + } else { + #check keys before we insert any of them. + foreach newkey $keys { + if {[string is integer -strict $newkey]} { + error "cannot accept key '$newkey', >collection keys must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + } + } + if {[llength $values] != [llength $keys]} { + error "unshift requires same number of keys as values. (or no keys for auto-generated keys) Received [llength $values] values, [llength $keys] keys" + } + + #separate loop through keys because we want to fail the whole operation if any are invalid. + + set existing_keys [dict keys $o_data] + foreach newkey $keys { + if {$newkey in $exisint_keys} { + #puts stderr "==============> key $key already exists in this collection" + error "key '$newkey' already exists in this collection" + } + } + + + #ok - looks like entire set can be inserted. + set newpairs [list] + foreach val $values key $keys { + lappend newpairs $key $val + } + set o_data [concat $newpairs $o_data[set o_data {}]] + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} + +#default to removing item from the beginning, otherwise from supplied index (position or key) +#!todo - accept alias indices +$COL .. PatternMethod shift {{idx ""}} { + var o_data o_count + + if {$idx eq ""} { + set key [lindex [dict keys $o_data] 0] + } else { + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + } + set posn [lsearch -exact [dict keys $o_data] $key] + + if {($posn >= 0) && (($posn/2) < [dict size $o_data])} { + set result [dict get $o_data $key] + dict unset o_data $key + set o_count [dict size $o_data] + return $result + } else { + error "no such index: '$idx'" + } +} + + +$COL .. PatternMethod peek {} { + var o_data + + #set o_array([lindex $o_list end]) + + #dict get $o_data [lindex [dict keys $o_data] end] + lindex $o_data end +} + +$COL .. PatternMethod peekKey {} { + var o_data + #lindex $o_list end + lindex $o_data end-1 +} + + +$COL .. PatternMethod insert {val args} { + var o_data o_count + + set idx 0 + set key "" + + if {[llength $args] <= 2} { + #standard arg (ordered) style: + #>obj . insert $value $position $key + + lassign $args idx key + } else { + #allow for literate programming style: + #e.g + # >obj . insert $value at $listPosition as $key + + if {[catch {array set iargs $args}]} { + error "insert did not understand argument list. +usage: +>obj . insert \$val \$position \$key +>obj . insert \$val at \$position as \$key" + } + if {[info exists iargs(at)]} { + set idx $iargs(at) + } + if {[info exists iargs(as)]} { + set key $iargs(as) + } + } + + if {![string length $key]} { + set key "_[::patternlib::uniqueKey]_" + } + + if {[string is integer -strict $key]} { + error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" + } + + + if {[dict exists $o_data $key]} { + #puts stderr "==============> key $key already exists in this collection" + error "key '$key' already exists in this collection" + } + + if {$idx eq "end"} { + #lappend o_list $key + #standard dict set will add it to the end anyway + dict set o_data $key $val + + } else { + #set o_list [linsert $o_list $idx $key] + + #treat dict as list + set o_data [linsert $o_data[set o_data {}] [expr {$idx*2}] $key $val] + } + + + #set o_array($key) $val + + + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} + +#!todo - deprecate and give it a better name! addDict addPairs ? +$COL .. PatternMethod addArray {list} { + var + puts stderr "patternlib::>collection WARNING: addArray deprecated - call addPairs with same argument instead" + tailcall addPairs $_ID_ $list +} +$COL .. PatternMethod addPairs {list} { + var o_data o_alias o_count + if {[llength $list] % 2} { + error "must supply an even number of elements" + } + + set aliaslist [array names o_alias] + #set keylist [dict keys $o_data] + foreach newkey [dict keys $list] { + if {[string is integer -strict $newkey] } { + error ">collection key must be non-integer. Bad key: $newkey. No items added." + } + + #if {$newkey in $keylist} {} + #for small to medium collections - testing for newkey in $keylist is probably faster, + # but we optimise here for potentially large existing collections, where presumably a dict exists lookup will be more efficient. + if {[dict exists $o_data $newkey]} { + error "key '$newkey' already exists in this collection. No items added." + } + #The assumption is that there are in general relatively few aliases - so a list test is appropriate + if {$newkey in $aliaslist} { + if {[dict exists $o_data $o_alias($newkey)]} { + error "key '$newkey' already exists as an alias for $o_alias($newkey) in collection. No items added " + } + } + #! check if $list contains dups? + #- slows method down - for little benefit? + } + #!todo - test? (but we need a loop to test for integer keys.. so what's the point?) + #set intersection [struct::set intersect [dict keys $list] [dict keys $o_data]] + #if {[llength $intersection]} { + # error "keys '$intersection' already present in this collection. No items added." + #} + + + #rely on dict ordering guarantees (post 8.5? preserves order?) + set o_data [dict merge $o_data[set o_data {}] $list] + + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} +$COL .. PatternMethod addList {list} { + var o_data o_count + + foreach val $list { + dict set o_data "_[::patternlib::uniqueKey]_" $val + #!todo - test. Presumably lappend faster because we don't need to check existing keys.. + #..but.. is there shimmering involved in treating o_data as a list? + #lappend o_data _[::patternlib::uniqueKey]_ $val + + #tested 2008-06 tcl8.6a0 lappend was slower as the gain is lost (and more!) during subsequent [dict size $o_data] + } + set o_count [dict size $o_data] + + return [expr {$o_count - 1}] +} + +#'del' is not a very good name... as we're not really 'deleting' anything. +# 'remove' seems better, and appears to be more consistent with other languages' collection implementations. +#!todo - handle 'endRange' parameter for removing ranges of items. +$COL .. PatternMethod del {idx {endRange ""}} { + var + #!todo - emit a deprecation warning for 'del' + tailcall remove $_ID_ $idx $endRange +} + +$COL .. PatternMethod remove {idx {endRange ""}} { + var o_data o_count o_alias this + + if {[string length $endRange]} { + error "ranged removal not yet implemented.. remove one item at a time." + } + + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + if {[catch {set o_alias($key)} nextKey]} { + error "no such index: '$idx' in collection: $this" + } else { + #try with next key in alias chain... + #return [remove $_ID_ $nextKey] + tailcall remove $_ID_ $nextKey + } + } + } + + dict unset o_data $key + + set o_count [dict size $o_data] + return +} + +#ordered +$COL .. PatternMethod names {{globOrIdx {}}} { + var o_data + + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + #Idx + set idx $globOrIdx + + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + + + + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "no such index : '$idx'" + } else { + return $result + } + + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } +} + +#ordered +$COL .. PatternMethod keys {} { + #like 'names' but without globbing + var o_data + dict keys $o_data +} + +#Unfortunately the string 'name' is highly collidable when mixing in a collection over existing objects +# - !todo - review. Is it worth adjusting the collection methodnames to avoid a few common collision cases? +# - some sort of resolution order/interface-selection is clearly required anyway +# so perhaps it's generally best not to bother being 'polite' here, and implement a robust understandable resolution mechanism. +# In the mean time however... we'll at least avoid 'name'! +# +#$PM name {{posn 0}} { +# var o_array o_list +# +# if {$posn < 0} { +# set posn "end-[expr {abs($posn + 1)}]" +# } +# +# if {[catch {lindex $o_list $posn} result]} { +# error "no such index : '$posn'" +# } else { +# return $result +# } +#} + +$COL .. PatternMethod key {{posn 0}} { + var o_data + + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "no such index : '$posn'" + } else { + return $result + } +} + + +#!todo - consider use of 'end-x' syntax for 'to', and implications re consistency with other commands. +$COL .. PatternMethod setPosn {idx to} { + var o_data + + if {![string is integer -strict $to]} { + error "destination position must be numeric, consider reKey method if you are trying to change the string key under which this value is stored" + } + + if {[string is integer -strict $idx]} { + set idx [expr {$idx % [dict size $o_data]}] + + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + } + + set to [expr {$to % [dict size $o_data]}] + + + set val [dict get $o_data $key] + dict unset o_data $key + + #treat dict as list + set o_data [linsert $o_data[set o_data {}] [expr {$posn*2}] $key $val] + + #set o_list [lreplace $o_list $posn $posn] + #set o_list [linsert $o_list $to $key] + + return $to +} +#!todo - improve efficiency of calls to other functions on this object.. 'inline'?? +#presumably the collection object functionality will be long-term stable because it's purpose is to be a core datastructure; therefore it should be reasonable to favour efficiency over maintainability. +$COL .. PatternMethod incrPosn {idx {by 1}} { + var o_data + if {[string is integer -strict $idx]} { + set idx [expr {$idx % [dict size $o_data]}] + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + } + + set newPosn [expr {($posn + $by) % [dict size $o_data]}] + + setPosn $_ID_ $posn $newPosn + return $newPosn +} +$COL .. PatternMethod decrPosn {idx {by 1}} { + var + return [incrPosn $_ID_ $idx [expr {- $by}]] +} +$COL .. PatternMethod move {idx to} { + var + return [setPosn $_ID_ $idx $to] +} +$COL .. PatternMethod posn {key} { + var o_data + return [lsearch -exact [dict keys $o_data] $key] +} + +#!todo? - disallow numeric values for newKey so as to be consistent with add +#!note! - item can be reKeyed out from under an alias such that the alias chain no longer points to anything +# - this is ok. +$COL .. PatternMethod reKey {idx newKey} { + var o_data o_alias + + + if {[dict exists $o_data $newKey]} { + #puts stderr "==============> reKey collision, key $newKey already exists in this collection" + error "reKey collision, key '$newKey' already exists in this collection" + } + if {[info exists o_alias($newKey)]} { + if {[dict exists $o_data $o_alias($newKey)]} { + error "reKey collision, key '$newKey' already present as an alias in this collection" + } else { + set newKey $o_alias($newKey) + } + } + + + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + if {[catch {set o_alias($key)} nextKey]} { + error "no such index: '$idx'" + } else { + #try with next key in alias chain... + #return [reKey $_ID_ $nextKey $newKey] + tailcall reKey $_ID_ $nextKey $newKey + } + } + } + + #set o_list [lreplace $o_list $posn $posn $newKey] + ##atomic? (traces on array?) + #set o_array($newKey) $o_array($key) + #unset o_array($key) + + dict set o_data $newKey [dict get $o_data $key] + dict unset o_data $key + + return +} +$COL .. PatternMethod hasKey {key} { + var o_data + dict exists $o_data $key +} +$COL .. PatternMethod hasAlias {key} { + var o_alias + info exists o_alias($key) +} + +#either key or alias +$COL .. PatternMethod hasIndex {key} { + var o_data o_alias + if {[dict exists $o_data $key]} { + return 1 + } else { + return [info exists o_alias($key)] + } +} + + +#Shuffle methods from http://mini.net/tcl/941 +$COL .. PatternMethod shuffleFast {} { + #shuffle6 - fast, but some orders more likely than others. + + var o_data + + set keys [dict keys $o_data] + + set n [llength $keys] + for { set i 1 } { $i < $n } { incr i } { + set j [expr { int( rand() * $n ) }] + set temp [lindex $keys $i] + lset keys $i [lindex $keys $j] + lset keys $j $temp + } + + #rebuild dict in new order + #!todo - can we do the above 'in place'? + set newdata [dict create] + foreach k $keys { + dict set newdata $k [dict get $o_data $k] + } + set o_data $newdata + + return +} +$COL .. PatternMethod shuffle {} { + #shuffle5a + + var o_data + + set n 1 + set keys [list] ;#sorted list of keys + foreach k [dict keys $o_data] { + #set index [expr {int(rand()*$n)}] + + #set slist [linsert [::pattern::K $keys [set keys {}]] $index $k] + + #faster alternative.. 'inline K' [lindex [list a b] 0] ~ [K a b] + set keys [linsert [lindex [list $keys [set keys {}]] 0] [expr {int(rand()*$n)}] $k] + incr n + } + + #rebuild dict in new order + #!todo - can we do the above 'in place'? + set newdata [dict create] + foreach k $keys { + dict set newdata $k [dict get $o_data $k] + } + set o_data $newdata + + return +} + + +#search is a somewhat specialised form of 'itemKeys' +$COL .. PatternMethod search {value args} { + var o_data + #only search on values as it's possible for keys to match - especially with options such as -glob + set matches [lsearch {*}$args [dict values $o_data] $value] + + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) * 2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } +} + +#inverse lookup +$COL .. PatternMethod itemKeys {value} { + var o_data + #only search on values as it's possible for keys to match + set value_indices [lsearch -all [dict values $o_data] $value] + + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) * 2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist +} + +#invert: +#change collection to be indexed by its values with the old keys as new values. +# - keys of duplicate values become a list keyed on the value. +#e.g the array equivalent is: +# arr(a) 1 +# arr(b) 2 +# arr(c) 2 +#becomes +# inv(1) a +# inv(2) {b c} +#where the order of duplicate-value keys is not defined. +# +#As the total number of keys may change on inversion - order is not preserved if there are ANY duplicates. +# + + +#!todo - try just [lreverse $o_data] ?? + + +$COL .. PatternMethod invert {{splitvalues ""}} { + + var o_data o_count o_dupes o_inverted + + + if {$splitvalues eq ""} { + #not overridden - use o_dupes from last call to determine if values are actually keylists. + if {$o_dupes > 0} { + set splitvalues 1 + } else { + set splitvalues 0 + } + } + + + #set data [array get o_array] + set data $o_data + + if {$o_count > 500} { + #an arbitrary optimisation for 'larger' collections. + #- should theoretically keep the data size and save some reallocations. + #!todo - test & review + # + foreach nm [dict keys $o_data] { + dict unset o_data $nm + } + } else { + set o_data [dict create] + } + + if {!$splitvalues} { + dict for {k v} $data { + dict set o_data $v $k + } + } else { + dict for {k v} $data { + #we're splitting values because each value is a list of keys + #therefore sub should be unique - no need for lappend in this branch. + foreach sub $v { + #if {[info exists o_array($sub)]} { + # puts stderr "---here! v:$v sub:$sub k:$k" + # lappend o_array($sub) $k + #} else { + dict set o_data $sub $k + #} + } + } + } + + + if {[dict size $o_data] != $o_count} { + #must have been some dupes + + set o_dupes [expr {$o_count - [dict size $o_data]}] + #update count to match inverted collection + set o_count [dict size $o_data] + } else { + set o_dupes 0 + } + + set o_inverted [expr {!$o_inverted}] + + #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' + return $o_dupes +} + + + + + + +#NOTE: values are treated as lists and split into separate keys for inversion only if requested! +# To treat values as keylists - set splitvalues 1 +# To treat each value atomically - set splitvalues 0 +# i.e only set splitvalues 1 if you know the values represent duplicate keys from a previous call to invert! +# +# +#Initially call invert with splitvalues = 0 +#To keep calling invert and get back where you started.. +# The rule is... if the previous call to invert returned > 0... pass 1 on the next call. +# +$COL .. PatternMethod invert_manual {{splitvalues 0}} { + #NOTE - the list nesting here is *tricky* - It probably isn't broken. + + var o_list o_array o_count + + set data [array get o_array] + + if {$o_count > 500} { + #an arbitrary optimisation for 'large' collections. + #- should theoretically keep the array size and save some reallocations. + #!todo - test & review + # + foreach nm [array names o_array] { + unset o_array($nm) + } + } else { + array unset o_array + } + + if {!$splitvalues} { + foreach {k v} $data { + lappend o_array($v) $k + } + } else { + foreach {k v} $data { + #we're splitting values because each value is a list of keys + #therefore sub should be unique - no need for lappend in this branch. + foreach sub $v { + #if {[info exists o_array($sub)]} { + # puts stderr "---here! v:$v sub:$sub k:$k" + # lappend o_array($sub) $k + #} else { + set o_array($sub) $k + #} + } + } + } + + + if {[array size o_array] != $o_count} { + #must have been some dupes + set o_list [array names o_array] + + + set dupes [expr {$o_count - [array size o_array]}] + #update count to match inverted collection + set o_count [array size o_array] + } else { + #review - are these machinations worthwhile for order preservation? what speed penalty do we pay? + array set prev $data + set i -1 + if {$splitvalues} { + #values are lists of length one. Take lindex 0 so list values aren't overnested. + foreach oldkey $o_list { + lset o_list [incr i] [lindex $prev($oldkey) 0] + } + } else { + foreach oldkey $o_list { + lset o_list [incr i] $prev($oldkey) + } + } + + set dupes 0 + } + + + #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' + return $dupes +} + + + +#Note that collections cannot be inverted without loss of information if they have duplicates AND compound keys +# (keys that are lists) +$COL .. PatternMethod invert_lossy {{splitvalues 1}} { + var o_list o_array o_count + + set data [array get o_array] + + if {$o_count > 500} { + #an arbitrary optimisation for 'large' collections. + #- should theoretically keep the array size and save some reallocations. + #!todo - test & review + # + foreach nm [array names o_array] { + unset o_array($nm) + } + } else { + array unset o_array + } + + if {!$splitvalues} { + foreach {k v} $data { + #note! we must check for existence and use 'set' for first case. + #using 'lappend' only will result in deeper nestings on each invert! + #If you don't understand this - don't change it! + if {[info exists o_array($v)]} { + lappend o_array($v) $k + } else { + set o_array($v) $k + } + } + } else { + foreach {k v} $data { + #length test necessary to avoid incorrect 'un-nesting' + #if {[llength $v] > 1} { + foreach sub $v { + if {[info exists o_array($sub)]} { + lappend o_array($sub) $k + } else { + set o_array($sub) $k + } + } + #} else { + # if {[info exists o_array($v)]} { + # lappend o_array($v) $k + # } else { + # set o_array($v) $k + # } + #} + } + } + + + if {[array size o_array] != $o_count} { + #must have been some dupes + set o_list [array names o_array] + + + set dupes [expr {$o_count - [array size o_array]}] + #update count to match inverted collection + set o_count [array size o_array] + } else { + #review - are these machinations worthwhile for order preservation? what speed penalty do we pay? + array set prev $data + set i -1 + foreach oldkey $o_list { + lset o_list [incr i] $prev($oldkey) + } + set dupes 0 + } + + + #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' + return $dupes +} + +$COL .. PatternMethod reverse {} { + var o_data + + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return +} + +$COL .. PatternMethod keySort {{options -ascii}} { + var o_data + + set keys [lsort {*}$options [dict keys $o_data]] + + set dictnew [dict create] + foreach k $keys { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + + return +} + +#!todo - allow simple options in combination with options such as -command and -object. Redo args handling completely for more complex sorting. +$COL .. PatternMethod sort {args} { + var o_data + + #defaults + set options [dict create -index 1] ;#values always in subelement 1 of name-value pair list for sorting. + + set options_simple [list] + + + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + switch -- $a { + -indices - + -ascii - + -dictionary - + -integer - + -real - + -increasing - + -decreasing { + #dict set options $a 1 + lappend options_simple $a + } + -unique { + #not a valid option + #this would stuff up the data... + #!todo? - remove dups from collection if this option used? - alias the keys? + } + -object { + #!todo - treat value as object and allow sorting by sub-values .eg >col1 . sort -object ". sub . property" -increasing + #may be slow - but handy. Consider -indexed property to store/cache these values on first run + } + -command { + dict set options $a [lindex $args [incr i]] + } + -index { + #allow sorting on subindices of the value. + dict set options -index [concat [dict get $options -index] [lindex $args [incr i]] ] + } + default { + #unrecognised option - print usage? + } + } + } + + + + if {[set posn [lsearch -exact $options_simple "-indices"]] >= 0} { + + var o_array + + set slist [list] + foreach k [dict keys $o_data] { + lappend slist [list $k [dict get $o_data $k]] + } + return [lsort {*}$options_simple {*}$options $slist] + + + + #set options_simple [lreplace $options_simple $posn $posn] ;# + #set slist [list] + #foreach {n v} [array get ::p::[lindex ${_ID_} 0 0]::o_array] { + # lappend slist [list $n $v] + #} + #set slist [lsort {*}$options_simple {*}$options $slist] + #foreach i $slist { + # #determine the position in the collections list + # lappend result {*}[lsearch -exact $o_list [lindex $i 0]] + #} + #return $result + } else { + set slist [list] + dict for {k v} $o_data { + lappend slist [list $k $v] + } + #set slist [lsort {*}$options_simple {*}$options $slist] + set slist [lsort {*}$options_simple {*}$options $slist[set slist {}]] ;#K combinator for efficiency + + + #set o_list [lsearch -all -inline -subindices -index 0 $slist *] + + set o_data [dict create] + foreach pair $slist { + dict set o_data [lindex $pair 0] [lindex $pair 1] + } + + + + return + } + +} + + +$COL .. PatternMethod clear {} { + var o_data o_count + + set o_data [dict create] + set o_count 0 + #aliases? + return +} + +#see http://wiki.tcl.tk/15271 - A generic collection traversal interface +# +#!todo - options: -progresscommand -errorcommand (-granularity ?) (-self ? (to convert to an iterator?)) +#!todo? - lazy retrieval of items so that all changes to the collection are available to a running asynch enumeration? +# - should this be an option? which mechanism should be the default? +# - currently only the keylist is treated in 'snapshot' fashion +# so values could be changed and the state could be invalidated by other code during an enumeration +# +$COL .. PatternMethod enumerate {args} { + #---------- + lassign [lrange $args end-1 end] cmd seed + set optionlist [list] + foreach a [lrange $args 0 end-2] { + lappend optionlist $a + } + set opt(-direction) left + set opt(-completioncommand) "" + array set opt $optionlist + #---------- + var o_data + + if {[string tolower [string index $opt(-direction) 0]] eq "r"} { + #'right' 'RIGHT' 'r' etc. + set list [lreverse [dict keys $o_data]] + } else { + #normal left-right order + set list [dict keys $o_data] + } + + if {![string length $opt(-completioncommand)]} { + #standard synchronous processing + foreach k $list { + set seed [uplevel #0 [list {*}$cmd $seed [dict get $o_data $k]]] + } + return $seed + } else { + #ASYNCHRONOUS enumeration + var this o_bgEnum + #!todo - make id unique + #!todo - facility to abort running enumeration. + set enumID enum[array size o_bgEnum] + + set seedvar [$this . bgEnum $enumID .] + set $seedvar $seed + + after 0 [list $this . _doBackgroundEnum $enumID $list $cmd $seedvar $opt(-completioncommand)] + return $enumID + } +} + +#!todo - make private? - put on a separate interface? +$COL .. PatternMethod _doBackgroundEnum {enumID slice cmd seedvar completioncommand} { + var this o_data + + + #Note that we don't post to the eventqueue using 'foreach s $slice' + # we only schedule another event after each item is processed + # - otherwise we would be spamming the eventqueue with items. + + #!todo? - accept a -granularity option to allow handling of n list-items per event? + + if {[llength $slice]} { + set slice [lassign $slice head] + + set script [string map [list %cmd% $cmd %seedvar% $seedvar %val% [dict get $o_data $head]] { + %cmd% [set %seedvar%] %val% + }] + + #post to eventqueue and re-enter _doBackgroundEnum + # + after idle [list after 0 [subst {set $seedvar \[uplevel #0 [list $script] \]; $this . _doBackgroundEnum $enumID [list $slice] [list $cmd] $seedvar [list $completioncommand]}]] + + } else { + #done. + + set script [string map [list %cmd% $completioncommand %seedvar% $seedvar] { + lindex [list [%cmd% [set %seedvar%]] [unset %seedvar%]] 0 + }] + + after idle [list after 0 [list uplevel #0 $script]] + } + + return +} + +$COL .. PatternMethod enumeratorstate {} { + var o_bgEnum + parray o_bgEnum +} + +#proc ::bgerror {args} { +# puts stderr "=bgerror===>$args" +#} + + +#map could be done in terms of the generic 'enumerate' method.. but it's slower. +# +#$PM map2 {proc} { +# var +# enumerate $_ID_ [list ::map-helper $proc] [list] +#} +#proc ::map-helper {proc accum item} { +# lappend accum [uplevel #0 [list {*}$proc $item]] +#} + +$COL .. PatternMethod map {cmd} { + var o_data + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + + return $seed +} +$COL .. PatternMethod objectmap {cmd} { + var o_data + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + + return $seed +} + + +#End core collection functionality. +#collection 'mixin' interfaces + +>pattern .. Create >keyvalprotector +>keyvalprotector .. PatternVariable o_protectedkeys +>keyvalprotector .. PatternVariable o_protectedvals + +#!todo - write test regarding errors in Constructors for mixins like this +# - an error (e.g from bad args) can cause errors with vars after it's re-run with correct args +>keyvalprotector .. Constructor {args} { + var this o_protectedkeys o_protectedvals + set this @this@ + #---------------------------------------------------------------------------- + set known_opts [list -keys -vals ] + dict set default -keys [list] + dict set default -vals [list] + if {([llength $args] % 2) != 0} { + error "(>keyvalprotector .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " + } + foreach {k v} $args { + if {$k ni $known_opts} { + error "(>keyvalprotector .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" + } + } + set opts [dict merge $default $args] + set o_protectedkeys [dict get $opts -keys] + set o_protectedvals [dict get $opts -vals] + #---------------------------------------------------------------------------- + set protections [concat $o_protectedkeys $o_protectedvals] + if {![llength $protections]} { + error "(>keyvalprotector .. Constructor) ERROR: must supply at least one argument to -vals or -keys" + } + +} +>keyvalprotector .. PatternMethod clear {} { + error "(>keyvalprotector . clear) ERROR: This collection is protected by a >keyvalprotector mixin. Cannot clear" +} +>keyvalprotector .. PatternMethod pop {{idx ""}} { + var o_data o_count o_protectedkeys o_protectedvals + + if {$idx eq ""} { + set key [lindex [dict keys $o_data] end] + } else { + if {[string is integer -strict $idx]} { + set key [lindex [dict keys $o_data] $idx] + } else { + set key $idx + } + } + + if {$key in $o_protectedkeys} { + error "(>keyvalprotector . pop) ERROR: Cannot pop object with index '$idx', key '$key' from collection." + } + set posn [lsearch -exact [dict keys $o_data] $key] + if {($posn >= 0) && ($posn < [dict size $o_data])} { + set result [dict get $o_data $key] + if {$result in $o_protectedvals} { + error "(>keyvalprotector . pop) ERROR: Cannot pop object '$result' with index '$idx', key '$key' from collection." + } + dict unset o_data $key + set o_count [dict size $o_data] + return $result + } else { + error "no such index: '$idx'" + } + +} +>keyvalprotector .. PatternMethod remove {idx {endRange ""}} { + var this o_data o_count o_alias o_protectedkeys o_protectedvals + + if {[string length $endRange]} { + error "ranged removal not yet implemented.. remove one item at a time." + } + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + set key [lindex [dict keys $o_data] $idx] + if {$key in $o_protectedkeys} { + error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' key '$key' from collection" + } + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + if {[catch {set o_alias($key)} nextKey]} { + error "no such index: '$idx' in collection: $this" + } else { + if {$key in $o_protectedkeys} { + error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' from collection" + } + #try with next key in alias chain... + #return [remove $_ID_ $nextKey] + tailcall remove $_ID_ $nextKey + } + } + } + + dict unset o_data $key + + set o_count [dict size $o_data] + return +} + +#1) +#predicate methods (order preserving) +#usage: +# >collection .. Create >c1 +# >predicatedCollection .. Create >c1 ;#overlay predicate methods on existing collection + +#e.g >col1 . all {$val > 14} +#e.g >col1 . filterToCollection {$val > 19} . count +#e.g >col1 . filter {[string match "x*" $key]} +#!todo - fix. currying fails.. + +::>pattern .. Create >predicatedCollection +#process_pattern_aliases ::patternlib::>predicatedCollection + +set PM [>predicatedCollection .. PatternMethod .] + +>predicatedCollection .. PatternMethod filter {predicate} { + var this o_list o_array + set result [list] + + #!note (jmn 2004) how could we do smart filtering based on $posn? + #i.e it would make sense to lrange $o_list based on $posn... + #but what about complicated expressions where $posn is a set of ranges and/or combined with tests on $key & $val ?? + #Seems better to provide an alternative efficient means of generating subcolllections/ranges to perform predicate operations upon. + #given this, is $posn even useful? + + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + lappend result $val + } + incr posn + } + set result +} +>predicatedCollection .. PatternMethod filterToKeys {predicate} { + var this o_list o_array + set result [list] + + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + lappend result $key + } + incr posn + } + set result +} +>predicatedCollection .. PatternMethod filterToCollection {predicate {destCollection {}}} { + #!todo - collection not in subordinate namespace? -> if subordinate, should imply modification of sub's contents will be reflected in parent? + #!todo - implement as 'view' on current collection object.. extra o_list variables? + #!todo - review/document 'expected' key collision behaviour - source keys used as dest keys.. -autokey option required? + var this o_list o_array m_i_filteredCollection + + incr m_i_filteredCollection + if {![string length $destCollection]} { + #!todo? - implement 'one-shot' object (similar to RaTcl) + set result [::patternlib::>collection .. Create [$this .. Namespace]::>filteredCollection-$m_i_filteredCollection] + } else { + set result $destCollection + } + + #### + #externally manipulate new collection + #set ADD [$c . add .] + #foreach key $o_list { + # set val $o_array($key) + # if $predicate { + # $ADD $val $key + # } + #} + ### + + #internal manipulation faster + #set cID [lindex [set $result] 0] + set cID [lindex [$result --] 0] + + #use list to get keys so as to preserve order + set posn 0 + upvar #0 ::p::${cID}::o_array cARRAY ::p::${cID}::o_list cLIST + foreach key $o_list { + set val $o_array($key) + if $predicate { + if {[info exists cARRAY($key)]} { + error "key '$key' already exists in this collection" + } + lappend cLIST $key + set cARRAY($key) $val + } + incr posn + } + + return $result +} + +#NOTE! unbraced expr/if statements. We want to evaluate the predicate. +>predicatedCollection .. PatternMethod any {predicate} { + var this o_list o_array + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + return 1 + } + incr posn + } + return 0 +} +>predicatedCollection .. PatternMethod all {predicate} { + var this o_list o_array + set posn 0 + foreach key $o_list { + set val $o_array($key) + if !($predicate) { + return 0 + } + incr posn + } + return 1 +} +>predicatedCollection .. PatternMethod dropWhile {predicate} { + var this o_list o_array + set result [list] + set _idx 0 + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + incr _idx + } else { + break + } + incr posn + } + set remaining [lrange $o_list $_idx end] + foreach key $remaining { + set val $o_array($key) + lappend result $val + } + return $result +} +>predicatedCollection .. PatternMethod takeWhile {predicate} { + var this o_list o_array + set result [list] + set posn 0 + foreach key $o_list { + set val $o_array($key) + if $predicate { + lappend result $val + } else { + break + } + incr posn + } + set result +} + + + +#end >collection mixins +###################################### + + + + +#----------------------------------------------------------- +#!TODO - methods for converting an arrayHandle to & from a hashMap efficiently? +# Why do we need both? apart from the size variable, what is the use of hashMap? +#----------------------------------------------------------- +#::pattern::create >hashMap +::>pattern .. Create >hashMap + +>hashMap .. PatternVariable o_size +>hashMap .. PatternVariable o_array + +>hashMap .. Constructor {args} { + var o_array o_size + array set o_array [list] + set o_size 0 +} +>hashMap .. PatternDefaultMethod "item" +>hashMap .. PatternMethod item {key} { + var o_array + set o_array($key) +} +>hashMap .. PatternMethod items {} { + var o_array + + set result [list] + foreach nm [array names o_array] { + lappend result $o_array($nm) + } + return $result +} +>hashMap .. PatternMethod pairs {} { + var o_array + + array get o_array +} +>hashMap .. PatternMethod add {val key} { + var o_array o_size + + set o_array($key) $val + incr o_size + return $key +} + +>hashMap .. PatternMethod del {key} { + var + puts stderr "warning: 'del' method of >hashMap deprecated. Use 'remove' instead." + remove $_ID_ $key +} +>hashMap .. PatternMethod remove {key} { + var o_array o_size + unset o_array($key) + incr o_size -1 + return $key +} +>hashMap .. PatternMethod count {} { + var o_size + #array size o_array + return $o_size +} +>hashMap .. PatternMethod count2 {} { + var o_array + #array size o_array ;#slow, at least for TCLv8.4.4 + #even array statistics is faster than array size ! + #e.g return [lindex [array statistics o_array] 0] + #but.. apparently there are circumstances where array statistics doesn't report the correct size. + return [array size o_array] +} +>hashMap .. PatternMethod names {} { + var o_array + array names o_array +} +>hashMap .. PatternMethod keys {} { + #synonym for names + var o_array + array names o_array +} +>hashMap .. PatternMethod hasKey {key} { + var o_array + return [info exists o_array($key)] +} +>hashMap .. PatternMethod clear {} { + var o_array o_size + unset o_array + set o_size 0 + return +} +#>hashMap .. Ready 1 + + + + + + + + + + + + + + + +#explicitly create metadata. Not required for user-defined patterns. +# this is only done here because this object is used for the metadata of all objects +# so the object must have all it's methods/props before its own metadata structure can be built. +#uplevel 1 "::pattern::object ::pattern::>_nullMeta createMetadata >collection" +#uplevel 1 "::patternlib::>collection .. CreateMetadata ::patternlib::>collection" + + + + +if 0 { + + +#----------------------------------------------------------- +#::pattern::create >arrayHandle { +# variable o_arrayName +# variable this +#} +::>pattern .. Create >arrayHandle + +>arrayHandle .. PatternVariable o_arrayName +>arrayHandle .. PatternVariable this + +>arrayHandle .. Constructor {args} { + var o_arrayName this + set this @this@ + + + set o_arrayName [$this .. Namespace]::array + + upvar #0 $o_arrayName $this + #? how to automatically update this after a namespace import? + + array set $o_arrayName [list] + +} +>arrayHandle .. PatternMethod array {} { + var o_arrayName + return $o_arrayName +} + +#------------------------------------------------------- +#---- some experiments +>arrayHandle .. PatternMethod up {varname} { + var o_arrayName + + #is it dodgy to hard-code the calling depth? + #will it be different for different object systems? + #Will it even be consistent for the same object. + # Is this method necessary anyway? - + # - users can always instead do: + # upvar #0 [>instance . array] var + + uplevel 3 [list upvar 0 $o_arrayName $varname] + + return +} +>arrayHandle .. PatternMethod global {varname} { + var o_arrayName + # upvar #0 [>instance . array] var + + if {![string match ::* $varname]} { + set varname ::$varname + } + + upvar #0 $o_arrayName $varname + + return +} +>arrayHandle .. PatternMethod depth {} { + var o_arrayName + # + for {set i 0} {$i < [info level]} { + puts "${i}: [uplevel $i [list namespace current] , [info level $i]]" + } + +} + # -------------------------------------------- + + +>arrayHandle .. PatternMethod item {key} { + var o_arrayName + set ${o_arrayName}($key) +} +>arrayHandle .. PatternMethod items {} { + var o_arrayName + + set result [list] + foreach nm [array names $o_arrayName] { + lappend result [set ${o_arrayName}($nm)] + } + return $result +} +>arrayHandle .. PatternMethod pairs {} { + var o_arrayName + + array get $o_arrayName +} +>arrayHandle .. PatternMethod add {val key} { + var o_arrayName + + set ${o_arrayName}($key) $val + return $key +} +>arrayHandle .. PatternMethod del {key} { + puts stderr "Warning: 'del' method of >arrayHandle deprecated. Use 'remove' instead." + remove $_ID_ $key +} +>arrayHandle .. PatternMethod remove {key} { + var o_arrayName + unset ${o_arrayName}($key) + return $key +} +>arrayHandle .. PatternMethod size {} { + var o_arrayName + return [array size $o_arrayName] +} +>arrayHandle .. PatternMethod count {} { + #alias for size + var o_arrayName + return [array size $o_arrayName] +} +>arrayHandle .. PatternMethod statistics {} { + var o_arrayName + return [array statistics $o_arrayName] +} +>arrayHandle .. PatternMethod names {} { + var o_arrayName + array names $o_arrayName +} +>arrayHandle .. PatternMethod keys {} { + #synonym for names + var o_arrayName + array names $o_arrayName +} +>arrayHandle .. PatternMethod hasKey {key} { + var o_arrayName + + return [info exists ${o_arrayName}($key)] +} +>arrayHandle .. PatternMethod clear {} { + var o_arrayName + unset $o_arrayName + array set $o_arrayName [list] + + return +} +#>arrayHandle .. Ready 1 + + + + +::>pattern .. Create >matrix + +>matrix .. PatternVariable o_array +>matrix .. PatternVariable o_size + +>matrix .. Constructor {args} { + var o_array o_size + + array set o_array [list] + set o_size 0 +} + + +#process_pattern_aliases ::patternlib::>matrix + +set PM [>matrix .. PatternMethod .] + +>matrix .. PatternMethod item {args} { + var o_array + + if {![llength $args]} { + error "indices required" + } else { + + } + if [info exists o_array($args)] { + return $o_array($args) + } else { + error "no such index: '$args'" + } +} +>matrix .. PatternMethod items {} { + var o_array + + set result [list] + foreach nm [array names o_array] { + lappend result $o_array($nm) + } + return $result +} +>matrix .. PatternMethod pairs {} { + var o_array + + array get o_array +} +>matrix .. PatternMethod slice {args} { + var o_array + + if {"*" ni $args} { + lappend args * + } + + array get o_array $args +} +>matrix .. PatternMethod add {val args} { + var o_array o_size + + if {![llength $args]} { + error "indices required" + } + + set o_array($args) $val + incr o_size + + #return [array size o_array] + return $o_size +} +>matrix .. PatternMethod names {} { + var o_array + array names o_array +} +>matrix .. PatternMethod keys {} { + #synonym for names + var o_array + array names o_array +} +>matrix .. PatternMethod hasKey {args} { + var o_array + + return [info exists o_array($args)] +} +>matrix .. PatternMethod clear {} { + var o_array o_size + unset o_array + set o_size 0 + return +} +>matrix .. PatternMethod count {} { + var o_size + return $o_size +} +>matrix .. PatternMethod count2 {} { + var o_array + #see comments for >hashMap count2 + return [array size o_array] +} +#>matrix .. Ready 1 + +#-------------------------------------------------------- +#tree data structure (based *loosely* on API at http://www.msen.com/%7Eclif/treeNobj.html - discussed in Clif Flynts book Tcl programming) +#!todo - compare API to http://tcllib.sourceforge.net/doc/tree.html +#!todo - create an >itree (inheritance tree) where node data is readable/writable on children unless overridden. +::>pattern .. Create >tree + +set _NODE [::>pattern .. Create [>tree .. Namespace]::>node] +set _TREE_NODE $_NODE +#process_pattern_aliases $_TREE_NODE + +$_NODE .. PatternVariable o_treens ;#tree namespace +$_NODE .. PatternVariable o_idref +$_NODE .. PatternVariable o_nodePrototype + +#$_NODE .. PatternProperty data +$_NODE .. PatternProperty info + +$_NODE .. PatternProperty tree +$_NODE .. PatternProperty parent +$_NODE .. PatternProperty children +$_NODE .. PatternMethod addNode {} { + set nd_id [incr $o_idref] + set nd [$o_nodePrototype .. Create ${o_treens}::>n-$nd_id -tree $o_tree -parent @this@] + @this@ . add $nd n-$nd_id + + return n-$nd_id +} +#flat list of all nodes below this +#!todo - something else? ad-hoc collections? +#!todo - non-recursive version? tail-call opt? +$_NODE .. PatternMethod nodes {} { + set result [list] + + #use(abuse?) our knowledge of >collection internals + foreach n $o_list { + #eval lappend result $n [$o_array($n) . nodes] + #!todo - test + lappend result $n {*}[$o_array($n) . nodes] + } + return $result +} +#count of number of descendants +#!todo - non-recursive version? tail-call opt? +$_NODE .. PatternMethod size {} { + set result 0 + #use(abuse?) our knowledge of >collection internals + foreach n $o_list { + incr result [expr {1 + [$o_array($n) . size]}] + } + return $result +} +$_NODE .. PatternMethod isLeaf {} { + #!todo - way to stop unused vars being uplevelled? + var o_tree + + #tailcall isEmpty $_ID_ ;#fails. because isEmpty is from >collection interface - so different ns? + tailcall [@this@ . isEmpty .] +} +$_NODE .. Constructor {args} { + array set A $args + + set o_tree $A(-tree) + set o_parent $A(-parent) + + #array set o_data [list] + array set o_info [list] + + set o_nodePrototype [::patternlib::>tree .. Namespace]::>node + set o_idref [$o_tree . nodeID .] + set o_treens [$o_tree .. Namespace] + #set o_children [::patternlib::>collection .. Create [@this@ .. Namespace]::>children] + + #overlay children collection directly on the node + set o_children [::patternlib::>collection .. Create @this@] + + return +} + +>tree .. PatternProperty test blah +>tree .. PatternProperty nodeID 0 ;#public only so node can access.. need 'friend' concept? +>tree .. PatternVariable o_ns +>tree .. Constructor {args} { + set o_ns [@this@ .. Namespace] + + #>tree is itself also a node (root node) + #overlay new 'root' node onto existing tree, pass tree to constructor + [::patternlib::>tree .. Namespace]::>node .. Create @this@ -tree @this@ -parent "" +} + + + + +unset _NODE + + + + +#-------------------------------------------------------- +#a basic binary search tree experiment +# - todo - 'scheme' property to change behaviour? e.g balanced tree +::>pattern .. Create >bst +#process_pattern_aliases ::patternlib::>bst +>bst .. PatternVariable o_NS ;#namespace +>bst .. PatternVariable o_this ;#namespace +>bst .. PatternVariable o_nodeID + +>bst .. PatternProperty root "" +>bst .. Constructor {args} { + set o_this @this@ + set o_NS [$o_this .. Namespace] + namespace eval ${o_NS}::nodes {} + puts stdout ">bst constructor" + set o_nodeID 0 +} +>bst .. PatternMethod insert {key args} { + set newnode [::patternlib::>bstnode .. Create ${o_NS}::nodes::>n-[incr o_nodeID]] + set [$newnode . key .] $key + if {[llength $args]} { + set [$newnode . value .] $args + } + if {![string length $o_root]} { + set o_root $newnode + set [$newnode . parent .] $o_this + } else { + set ipoint {} ;#insertion point + set tpoint $o_root ;#test point + set side {} + while {[string length $tpoint]} { + set ipoint $tpoint + if {[$newnode . key] < [$tpoint . key]} { + set tpoint [$tpoint . left] + set side left + } else { + set tpoint [$tpoint . right] + set side right + } + } + set [$newnode . parent .] $ipoint + set [$ipoint . $side .] $newnode + } + return $newnode +} +>bst .. PatternMethod item {key} { + if {![string length $o_root]} { + error "item $key not found" + } else { + set tpoint $o_root + while {[string length $tpoint]} { + if {[$tpoint . key] eq $key} { + return $tpoint + } else { + if {$key < [$tpoint . key]} { + set tpoint [$tpoint . left] + } else { + set tpoint [$tpoint . right] + } + } + } + error "item $key not found" + } +} +>bst .. PatternMethod inorder-walk {} { + if {[string length $o_root]} { + $o_root . inorder-walk + } + puts {} +} +>bst .. PatternMethod view {} { + array set result [list] + + if {[string length $o_root]} { + array set result [$o_root . view 0 [list]] + } + + foreach depth [lsort [array names result]] { + puts "$depth: $result($depth)" + } + +} +::>pattern .. Create >bstnode +#process_pattern_aliases ::patternlib::>bstnode +>bstnode .. PatternProperty parent +>bstnode .. PatternProperty left "" +>bstnode .. PatternProperty right "" +>bstnode .. PatternProperty key +>bstnode .. PatternProperty value + +>bstnode .. PatternMethod inorder-walk {} { + if {[string length $o_left]} { + $o_left . inorder-walk + } + + puts -nonewline "$o_key " + + if {[string length $o_right]} { + $o_right . inorder-walk + } + + return +} +>bstnode .. PatternMethod view {depth state} { + #!todo - show more useful representation of structure + set lower [incr depth] + + if {[string length $o_left]} { + set state [$o_left . view $lower $state] + } + + if {[string length $o_right]} { + set state [$o_right . view $lower $state] + } + + + array set s $state + lappend s($depth) $o_key + + return [array get s] +} + + +#-------------------------------------------------------- +#::pattern::create ::pattern::>metaObject +#::pattern::>metaObject PatternProperty methods +#::pattern::>metaObject PatternProperty properties +#::pattern::>metaObject PatternProperty PatternMethods +#::pattern::>metaObject PatternProperty patternProperties +#::pattern::>metaObject Constructor args { +# set this @this@ +# +# set [$this . methods .] [::>collection create [$this namespace]::methods] +# set [$this . properties .] [::>collection create [$this namespace]::properties] +# set [$this . PatternMethods .] [::>collection create [$this namespace]::PatternMethods] +# set [$this . patternProperties .] [::>collection create [$this namespace]::patternProperties] +# +#} + + + + #tidy up + unset PV + unset PM + + + +#-------------------------------------------------------- +::>pattern .. Create >enum +#process_pattern_aliases ::patternlib::>enum +>enum .. PatternMethod item {{idx 0}} { + var o_array o_list + + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {set o_array([lindex $o_list $idx])} result]} { + error "no such index : '$idx'" + } else { + return $result + } + } else { + if {[catch {set o_array($idx)} result]} { + error "no such index: '$idx'" + } else { + return $result + } + } +} + + + +#proc makeenum {type identifiers} { +# #!!todo - make generated procs import into whatever current system context? +# +# upvar #0 wbpbenum_${type}_number a1 wbpbenum_number_${type} a2 +# +# #obliterate any previous enum for this type +# catch {unset a1} +# catch {unset a2} +# +# set n 0 +# foreach id $identifiers { +# set a1($id) $n +# set a2($n) $id +# incr n +# } +# proc ::${type}_to_number key [string map [list @type@ $type] { +# upvar #0 wbpbenum_@type@_number ary +# if {[catch {set ary($key)} num]} { +# return -code error "unknown @type@ '$key'" +# } +# return $num +# }] +# +# proc ::number_to_${type} {number} [string map [list @type@ $type] { +# upvar #0 wbpbenum_number_@type@ ary +# if {[catch {set ary($number)} @type@]} { +# return -code error "no @type@ for '$number'" +# } +# return $@type@ +# }] +# +# #eval "namespace eval ::sysnexus {namespace export number_to_${type}; namespace export ${type}_to_number}" +# #eval "namespace eval :: {namespace import -force sysnexus::number_to_${type} sysnexus::${type}_to_number}" +#} +# +#-------------------------------------------------------- +::>pattern .. Create >nest +>nest .. PatternVariable THIS +>nest .. PatternProperty data -autoclone +>nest .. Constructor {args} { + var o_data + var THIS + set THIS @this@ + array set o_data [list] +} +>nest .. PatternMethod item {args} { + set THIS @this@ + return [$THIS . data [join $args ,]] +} + +# +# e.g +# set [>nest a , b . data c .] blah +# >nest a , b , c +# +# set [>nest w x , y . data z .] etc +# >nest w x , y , z +#-------------------------------------------------------- + +} + +} + + +#package require patternlibtemp diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm new file mode 100644 index 00000000..680ea88f --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm @@ -0,0 +1,754 @@ +package provide patternpredator2 1.2.4 + +proc ::p::internals::jaws {OID _ID_ args} { + #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" + #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + yield + set w 1 + + set stack [list] + set wordcount [llength $args] + set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first + set unsupported 0 + set operator "" + set operator_prev "" ;#used only by argprotect to revert to previous operator + + + if {$OID ne "null"} { + #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) + #upvar #0 ::p::${OID}::_meta::map MAP + set MAP [set ::p::${OID}::_meta::map] + } else { + # error "jaws - OID = 'null' ???" + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key + } + set invocantdata [dict get $MAP invocantdata] + lassign $invocantdata OID alias default_method object_command wrapped + + set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code + + #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w + while {$w < $wordcount} { + set word [lindex $args [expr {$w -1}]] + #puts stdout "w:$w word:$word stack:$stack" + + if {$operator eq "argprotect"} { + set operator $operator_prev + lappend stack $word + incr w + } else { + if {[llength $stack]} { + if {$word in $terminals} { + set reduction [list 0 $_ID_ {*}$stack ] + #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" + + + set _ID_ [yield $reduction] + set stack [list] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] + #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" + } + + #review - 2018. switched to _ID_ instead of MAP + lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command + #lassign [dict get $MAP invocantdata] OID alias default_method object_command + + + #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" + set operator $word + #don't incr w + #incr w + } else { + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + lappend stack $word + } else { + #only look for leading argprotect chacter (-) if we're not already in argprotect mode + if {$word eq "--"} { + set operator_prev $operator + set operator "argprotect" + #Don't add the plain argprotector to the stack + } elseif {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + } + + + incr w + } + } else { + #no stack + switch -- $word {.} { + + if {$OID ne "null"} { + #we know next word is a property or method of a pattern object + incr w + set nextword [lindex $args [expr {$w - 1}]] + set command ::p::${OID}::$nextword + set stack [list $command] ;#2018 j + set operator . + if {$w eq $wordcount} { + set finished_args 1 + } + } else { + # don't incr w + #set nextword [lindex $args [expr {$w - 1}]] + set command $object_command ;#taken from the MAP + set stack [list "_exec_" $command] + set operator . + } + + + } {..} { + incr w + set nextword [lindex $args [expr {$w -1}]] + set command ::p::-1::$nextword + #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. + set stack [list $command] ;#faster, and intent is clearer than lappend. + set operator .. + if {$w eq $wordcount} { + set finished_args 1 + } + } {,} { + #puts stdout "Stackless comma!" + + + if {$OID ne "null"} { + set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + #object_command in this instance presumably be a list and $default_method a list operation + #e.g "lindex {A B C}" + } + #lappend stack $command + set stack [list $command] + set operator , + } {--} { + set operator_prev $operator + set operator argprotect + #no stack - + } {!} { + set command $object_command + set stack [list "_exec_" $object_command] + #puts stdout "!!!! !!!! $stack" + set operator ! + } default { + if {$operator eq ""} { + if {$OID ne "null"} { + set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + } + set stack [list $command] + set operator , + lappend stack $word + } else { + #no stack - so we don't expect to be in argprotect mode already. + if {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + + } + } + incr w + } + + } + } ;#end while + + #process final word outside of loop + #assert $w == $wordcount + #trailing operators or last argument + if {!$finished_args} { + set word [lindex $args [expr {$w -1}]] + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + + lappend stack $word + incr w + } else { + + + switch -- $word {.} { + if {![llength $stack]} { + #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] + yieldto return [::p::internals::ref_to_object $_ID_] + error "assert: never gets here" + + } else { + #puts stdout "==== $stack" + #assert - whenever _ID_ changed in this proc - we have updated the $OID variable + yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] + error "assert: never gets here" + } + set operator . + + } {..} { + #trailing .. after chained call e.g >x . item 0 .. + #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" + #set reduction [list 0 $_ID_ {*}$stack] + yieldto return [yield [list 0 $_ID_ {*}$stack]] + } {#} { + set unsupported 1 + } {,} { + set unsupported 1 + } {&} { + set unsupported 1 + } {@} { + set unsupported 1 + } {--} { + + #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] + #puts stdout " -> -> -> about to call yield $reduction <- <- <-" + set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] + } + yieldto return $MAP + } {!} { + #error "untested branch" + set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] + #set OID [::pattern::get_oid $_ID_] + set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + if {$OID ne "null"} { + set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! + } else { + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] + } + lassign [dict get $MAP invocantdata] OID alias default_command object_command + set command $object_command + set stack [list "_exec_" $command] + set operator ! + } default { + if {$operator eq ""} { + #error "untested branch" + lassign [dict get $MAP invocantdata] OID alias default_command object_command + #set command ::p::${OID}::item + set command ::p::${OID}::$default_command + lappend stack $command + set operator , + + } + #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. + lappend stack $word + } + if {$unsupported} { + set unsupported 0 + error "trailing '$word' not supported" + + } + + #if {$operator eq ","} { + # incr wordcount 2 + # set stack [linsert $stack end-1 . item] + #} + incr w + } + } + + + #final = 1 + #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" + + return [list 1 $_ID_ {*}$stack] +} + + + +#trailing. directly after object +proc ::p::internals::ref_to_object {_ID_} { + set OID [lindex [dict get $_ID_ i this] 0 0] + upvar #0 ::p::${OID}::_meta::map MAP + lassign [dict get $MAP invocantdata] OID alias default_method object_command + set refname ::p::${OID}::_ref::__OBJECT + + array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces + + set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" + trace add variable $refname {read} $traceCmd + } + set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] + if {[list {array} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {array} $traceCmd + } + + set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] + if {[list {write} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {write} $traceCmd + } + + set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] + if {[list {unset} $traceCmd] ni [trace info variable $refname]} { + trace add variable $refname {unset} $traceCmd + } + return $refname +} + + +proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { + #if {[lindex $fullstack 0] eq "_exec_"} { + # #strip it. This instruction isn't relevant for a reference. + # set commandstack [lrange $fullstack 1 end] + #} else { + # set commandstack $fullstack + #} + #set argstack [lassign $commandstack command] + #set field [string map {> __OBJECT_} [namespace tail $command]] + + + + set reftail [namespace tail $refname] + set argstack [lassign [split $reftail +] field] + set field [string map {> __OBJECT_} [namespace tail $command]] + + #puts stderr "refname:'$refname' command: $command field:$field" + + + if {$OID ne "null"} { + upvar #0 ::p::${OID}::_meta::map MAP + } else { + #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] + set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] + } + lassign [dict get $MAP invocantdata] OID alias default_method object_command + + + + if {$OID ne "null"} { + interp alias {} $refname {} $command $_ID_ {*}$argstack + } else { + interp alias {} $refname {} $command {*}$argstack + } + + + #set iflist [lindex $map 1 0] + set iflist [dict get $MAP interfaces level0] + #set iflist [dict get $MAP interfaces level0] + set field_is_property_like 0 + foreach IFID [lreverse $iflist] { + #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. + if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { + set field_is_property_like 1 + #There is a setter or getter (but not necessarily an entry in the o_properties dict) + break + } + } + + + + + #whether field is a property or a method - remove any commandrefMisuse_TraceHandler + foreach tinfo [trace info variable $refname] { + #puts "-->removing traces on $refname: $tinfo" + if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { + trace remove variable $refname {*}$tinfo + } + } + + if {$field_is_property_like} { + #property reference + + + set this_invocantdata [lindex [dict get $_ID_ i this] 0] + lassign $this_invocantdata OID _alias _defaultmethod object_command + #get fully qualified varspace + + # + set propdict [$object_command .. GetPropertyInfo $field] + if {[dict exist $propdict $field]} { + set field_is_a_property 1 + set propinfo [dict get $propdict $field] + set varspace [dict get $propinfo varspace] + if {$varspace eq ""} { + set full_varspace ::p::${OID} + } else { + if {[::string match "::*" $varspace]} { + set full_varspace $varspace + } else { + set full_varspace ::p::${OID}::$varspace + } + } + } else { + set field_is_a_property 0 + #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property + #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) + set full_varspace ::p::${OID} + } + + + + + + #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) + set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] + if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { + trace add variable ${full_varspace}::o_${field} {write} $Hndlr + } + set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] + if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { + trace add variable ${full_varspace}::o_${field} {unset} $Hndlr + } + + + #supply all data in easy-access form so that propref_trace_read is not doing any extra work. + set get_cmd ::p::${OID}::(GET)$field + set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] + + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + set fieldvarname ${full_varspace}::o_${field} + + + #synch the refvar with the real var if it exists + #catch {set $refname [$refname]} + if {[array exists $fieldvarname]} { + if {![llength $argstack]} { + #unindexed reference + array set $refname [array get $fieldvarname] + #upvar $fieldvarname $refname + } else { + set s0 [lindex $argstack 0] + #refs to nonexistant array members common? (catch vs 'info exists') + if {[info exists ${fieldvarname}($s0)]} { + set $refname [set ${fieldvarname}($s0)] + } + } + } else { + #refs to uninitialised props actually should be *very* common. + #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. + #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. + + #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! + + #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" + + + if {![llength $argstack]} { + #catch {set $refname [set ::p::${OID}::o_$field]} + if {[info exists $fieldvarname]} { + set $refname [set $fieldvarname] + #upvar $fieldvarname $refname + } + } else { + if {[llength $argstack] == 1} { + #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] + } + + } else { + #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] $argstack] + } + } + } + + #! what if someone has put a trace on ::errorInfo?? + #set ::errorInfo $errorInfo_prev + } + trace add variable $refname {read} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] + trace add variable $refname {write} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] + trace add variable $refname {unset} $traceCmd + + + set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] + # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" + trace add variable $refname {array} $traceCmd + } + + } else { + #puts "$refname ====> adding refMisuse_traceHandler $alias $field" + #matching variable in order to detect attempted use as property and throw error + + #2018 + #Note that we are adding a trace on a variable (the refname) which does not exist. + #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) + #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added + ##array set $refname {} ;#empty array + # - the empty array would mean a slightly better error message when misusing a command ref as an array + #but this seems like a code complication for little benefit + #review + + trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] + } +} + + + +#trailing. after command/property +proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { + if {[lindex $fullstack 0] eq "_exec_"} { + #strip it. This instruction isn't relevant for a reference. + set commandstack [lrange $fullstack 1 end] + } else { + set commandstack $fullstack + } + set argstack [lassign $commandstack command] + set field [string map {> __OBJECT_} [namespace tail $command]] + + + #!todo? + # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. + # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. + + + #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. + # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. + + + set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] + + if {[llength [info commands $refname]]} { + #todo - review - what if the field changed to/from a property/method? + #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs + return $refname + } + ::p::internals::create_or_update_reference $OID $_ID_ $refname $command + return $refname +} + + +namespace eval pp { + variable operators [list .. . -- - & @ # , !] + variable operators_notin_args "" + foreach op $operators { + append operators_notin_args "({$op} ni \$args) && " + } + set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands + #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} +} +interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! + + + + + +# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. +#each map is a 2 element list of lists. +# form: {$commandinfo $interfaceinfo} +# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} + +#2018 +#each map is a dict. +#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} + + +#OID = Object ID (integer for now - could in future be a uuid) +proc ::p::predator2 {_ID_ args} { + #puts stderr "predator2: _ID_:'$_ID_' args:'$args'" + #set invocants [dict get $_ID_ i] + #set invocant_roles [dict keys $invocants] + + #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. + #set this_role_members [dict get $invocants this] + #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. + #lassign $this_invocant this_OID this_info_dict + + set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid + + + set cheat 1 ;# + #------- + #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) + #(it should be functionally equivalent to remove this shortcut block) + if {$cheat} { + if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { + + set remaining_args [lassign $args dot method_or_prop] + + #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? + set command ::p::${this_OID}::$method_or_prop + #REVIEW! + #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') + #if {[llength $command] > 1} { + # error "methods with spaces not included in test suites - todo fix!" + #} + #Dont use {*}$command - (so we can support methods with spaces) + #if {![llength [info commands $command]]} {} + if {[namespace which $command] eq ""} { + if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { + #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces + set command ::p::${this_OID}::(UNKNOWN) + #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" + } + } else { + #tailcall {*}$command $_ID_ {*}$remaining_args + tailcall $command $_ID_ {*}$remaining_args + } + } + } + #------------ + + + if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { + return $_ID_ + } + + + #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" + + + + #puts stderr "this_info_dict: $this_info_dict" + + + + + if {![llength $args]} { + #should return some sort of public info.. i.e probably not the ID which is an implementation detail + #return cmd + return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID + + #return a dict keyed on object command name - (suitable as use for a .. Create 'target') + #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped + #return [list $object_command [list -id $this_OID ]] + } elseif {[llength $args] == 1} { + #short-circuit the single index case for speed. + if {[lindex $args 0] ni {.. . -- - & @ # , !}} { + #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method + lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method + + tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] + } elseif {[lindex $args 0] eq {--}} { + + #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. + # - combined with using UUIDs for $OID, and a secured/removed metaface on the object + # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) + # - this could effectively hide the object's namespaces,vars etc from the caller (?) + return [set ::p::${this_OID}::_meta::map] + } + } + + + + #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) + #incr c + #set reduce ::p::reducer${this_OID}_$c + set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] + #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" + coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args + + + set current_ID_ $_ID_ + + set final 0 + set result "" + while {$final == 0} { + #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) + set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] + #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" + #if {[string match *Destroy $command]} { + # puts stdout " calling Destroy reduction_args:'$reduction_args'" + #} + if {$final == 1} { + + if {[llength $command] == 1} { + if {$command eq "_exec_"} { + tailcall {*}$reduction_args + } + if {[llength [info commands $command]]} { + tailcall {*}$command $current_ID_ {*}$reduction_args + } + set cmdname [namespace tail $command] + set this_OID [lindex [dict get $current_ID_ i this] 0 0] + if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { + lset command 0 ::p::${this_OID}::(UNKNOWN) + tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" + } + + } else { + #e.g lindex {a b c} + tailcall {*}$command {*}$reduction_args + } + + + } else { + if {[lindex $command 0] eq "_exec_"} { + set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] + + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] + } else { + if {[llength $command] == 1} { + if {![llength [info commands $command]]} { + set cmdname [namespace tail $command] + set this_OID [lindex [dict get $current_ID_ i this] 0 0] + if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { + + lset command 0 ::p::${this_OID}::(UNKNOWN) + set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" + } + } else { + #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] + set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] + + } + } else { + set result [uplevel 1 [list {*}$command {*}$reduction_args]] + } + + if {[llength [info commands $result]]} { + if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { + #looks like a pattern command + set current_ID_ [$result .. INVOCANTDATA] + + + #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA + #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { + # set current_ID_ $result_invocantdata + #} else { + # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" + #} + } else { + #non-pattern command + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + } + } else { + set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) + + } + } + + } + } + error "Assert: Shouldn't get here (end of ::p::predator2)" + #return $result +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/promise-1.2.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/promise-1.2.0.tm new file mode 100644 index 00000000..a4b82e45 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/promise-1.2.0.tm @@ -0,0 +1,1311 @@ +# Copyright (c) 2015-2023, Ashok P. Nadkarni +# All rights reserved. + +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: + +# 1. Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. + +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. + +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +package require Tcl 8.6- + +namespace eval promise { + proc version {} { return 1.2.0 } +} + +proc promise::lambda {params body args} { + # Creates an anonymous procedure and returns a command prefix for it. + # params - parameter definitions for the procedure + # body - body of the procedures + # args - additional arguments to be passed to the procedure when it + # is invoked + # + # This is just a convenience command since anonymous procedures are + # commonly useful with promises. The lambda package from tcllib + # is identical in function. + + return [list ::apply [list $params $body] {*}$args] +} + +catch {promise::Promise destroy} +oo::class create promise::Promise { + + # The promise state can be one of + # PENDING - Initial state where it has not yet been assigned a + # value or error + # FULFILLED - The promise has been assigned a value + # REJECTED - The promise has been assigned an error + # CHAINED - The promise is attached to another promise + variable _state + + # Stores data that is accessed through the setdata/getdata methods. + # The Promise class itself does not use this. + variable _clientdata + + # The promise value once it is fulfilled or rejected. In the latter + # case, it should be an the error message + variable _value + + # The error dictionary in case promise is rejected + variable _edict + + # Reactions to be notified when the promise is rejected. Each element + # in this list is a pair consisting of the fulfilment reaction + # and the rejection reaction. Either element of the pair could be + # empty signifying no reaction for that case. The list is populated + # via the then method. + variable _reactions + + # Reference counting to free up promises since Tcl does not have + # garbage collection for objects. Garbage collection via reference + # counting only takes place after at least one done/then reaction + # is placed on the event queue, not before. Else promises that + # are immediately resolved on construction would be freed right + # away before the application even gets a chance to call done/then. + variable _do_gc + variable _nrefs + + # If no reject reactions are registered, then the Tcl bgerror + # handler is invoked. But don't want to do this more than once + # so track it + variable _bgerror_done + + constructor {cmd} { + # Create a promise for the asynchronous operation to be initiated + # by $cmd. + # cmd - a command prefix that should initiate an asynchronous + # operation. + # The command prefix $cmd is passed an additional argument - the + # name of this Promise object. It should arrange for one of the + # object's settle methods [fulfill], [chain] or + # [reject] to be called when the operation completes. + + set _state PENDING + set _reactions [list ] + set _do_gc 0 + set _bgerror_done 0 + set _nrefs 0 + array set _clientdata {} + + # Errors in the construction command are returned via + # the standard mechanism of reject. + # + if {[catch { + # For some special cases, $cmd may be "" if the async operation + # is initiated outside the constructor. This is not a good + # thing because the error in the initiator will not be + # trapped via the standard promise error catching mechanism + # but that's the application's problem (actually pgeturl also + # uses this). + if {[llength $cmd]} { + uplevel #0 [linsert $cmd end [self]] + } + } msg edict]} { + my reject $msg $edict + } + } + + destructor { + # Destroys the object. + # + # This method should not be generally called directly as [Promise] + # objects are garbage collected either automatically or via the [ref] + # and [unref] methods. + } + + method state {} { + # Returns the current state of the promise. + # + # The promise state may be one of the values `PENDING`, + # `FULFILLED`, `REJECTED` or `CHAINED` + return $_state + } + + method getdata {key} { + # Returns data previously stored through the setdata method. + # key - key whose associated values is to be returned. + # An error will be raised if no value is associated with the key. + return $_clientdata($key) + } + + method setdata {key value} { + # Sets a value to be associated with a key. + # key - the lookup key + # value - the value to be associated with the key + # A promise internally maintains a dictionary whose values can + # be accessed with the [getdata] and [setdata] methods. This + # dictionary is not used by the Promise class itself but is meant + # to be used by promise library specializations or applications. + # Callers need to take care that keys used for a particular + # promise are sufficiently distinguishable so as to not clash. + # + # Returns the value stored with the key. + set _clientdata($key) $value + } + + method value {} { + # Returns the settled value for the promise. + # + # The returned value may be the fulfilled value or the rejected + # value depending on whether the associated operation was successfully + # completed or failed. + # + # An error is raised if the promise is not settled yet. + if {$_state ni {FULFILLED REJECTED}} { + error "Value is not set." + } + return $_value + } + + method ref {} { + # Increments the reference count for the object. + incr _nrefs + } + + method unref {} { + # Decrements the reference count for the object. + # + # The object may have been destroyed when the call returns. + incr _nrefs -1 + my GC + } + + method nrefs {} { + # Returns the current reference count. + # + # Use for debugging only! Note, internal references are not included. + return $_nrefs + } + + method GC {} { + if {$_nrefs <= 0 && $_do_gc && [llength $_reactions] == 0} { + my destroy + } + } + + method FulfillAttached {value} { + if {$_state ne "CHAINED"} { + return + } + set _value $value + set _state FULFILLED + my ScheduleReactions + return + } + + method RejectAttached {reason edict} { + if {$_state ne "CHAINED"} { + return + } + set _value $reason + set _edict $edict + set _state REJECTED + my ScheduleReactions + return + } + + # Method to invoke to fulfil a promise with a value or another promise. + method fulfill {value} { + # Fulfills the promise. + # value - the value with which the promise is fulfilled + # + # Returns `0` if promise had already been settled and `1` if + # it was fulfilled by the current call. + + #ruff + # If the promise has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; # Already settled + } + + #ruff + # Otherwise, it is transitioned to the `FULFILLED` state with + # the value specified by $value. If there are any fulfillment + # reactions registered by the [Promise.done] or [Promise.then] methods, they + # are scheduled to be run. + set _value $value + set _state FULFILLED + my ScheduleReactions + return 1 + } + + # Method to invoke to fulfil a promise with a value or another promise. + method chain {promise} { + # Chains the promise to another promise. + # promise - the [Promise] object to which this promise is to + # be chained + # + # Returns `0` if promise had already been settled and `1` otherwise. + + #ruff + # If the promise on which this method is called + # has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; + } + + #ruff + # Otherwise, it is chained to $promise so that it reflects that + # other promise's state. + if {[catch { + $promise done [namespace code {my FulfillAttached}] [namespace code {my RejectAttached}] + } msg edict]} { + my reject $msg $edict + } else { + set _state CHAINED + } + + return 1 + } + + method reject {reason {edict {}}} { + # Rejects the promise. + # reason - a message string describing the reason for the rejection. + # edict - a Tcl error dictionary + # + # The $reason and $edict values are passed on to the rejection + # reactions. By convention, these should be of the form returned + # by the `catch` or `try` commands in case of errors. + # + # Returns `0` if promise had already been settled and `1` if + # it was rejected by the current call. + + #ruff + # If the promise has already been settled, the method has no effect. + if {$_state ne "PENDING"} { + return 0; # Already settled + } + + #ruff + # Otherwise, it is transitioned to the `REJECTED` state. If + # there are any reject reactions registered by the [Promise.done] or + # [Promise.then] methods, they are scheduled to be run. + + set _value $reason + #ruff + # If $edict is not specified, or specified as an empty string, + # a suitable error dictionary is constructed in its place + # to be passed to the reaction. + if {$edict eq ""} { + catch {throw {PROMISE REJECTED} $reason} - edict + } + set _edict $edict + set _state REJECTED + my ScheduleReactions + return 1 + } + + # Internal method to queue all registered reactions based on + # whether the promise is succesfully fulfilled or not + method ScheduleReactions {} { + if {$_state ni {FULFILLED REJECTED} || [llength $_reactions] == 0 } { + # Promise is not settled or no reactions registered + return + } + + # Note on garbage collection: garbage collection is to be enabled if + # at least one FULFILLED or REJECTED reaction is registered. + # Also if the promise is REJECTED but no rejection handlers are run + # we also schedule a background error. + # In all cases, CLEANUP reactions do not count. + foreach reaction $_reactions { + foreach type {FULFILLED REJECTED} { + if {[dict exists $reaction $type]} { + set _do_gc 1 + if {$type eq $_state} { + set cmd [dict get $reaction $type] + if {[llength $cmd]} { + if {$type eq "FULFILLED"} { + lappend cmd $_value + } else { + lappend cmd $_value $_edict + } + set ran_reaction($type) 1 + # Enqueue the reaction via the event loop + after 0 [list after idle $cmd] + } + } + } + } + if {[dict exists $reaction CLEANUP]} { + set cmd [dict get $reaction CLEANUP] + if {[llength $cmd]} { + # Enqueue the cleaner via the event loop passing the + # *state* as well as the value + if {$_state eq "REJECTED"} { + lappend cmd $_state $_value $_edict + } else { + lappend cmd $_state $_value + } + after 0 [list after idle $cmd] + # Note we do not set _do_gc if we only run cleaners + } + } + } + set _reactions [list ] + + # Check for need to background error (see comments above) + if {$_state eq "REJECTED" && $_do_gc && ! [info exists ran_reaction(REJECTED)] && ! $_bgerror_done} { + # TBD - should we also check _nrefs before backgrounding error? + + # Wrap in catch in case $_edict does not follow error conventions + # or is not even a dictionary + if {[catch { + dict get $_edict -level + dict get $_edict -code + }]} { + catch {throw {PROMISE REJECT} $_value} - edict + } else { + set edict $_edict + } + # TBD - how exactly is level to be handled? + # If -level is not 0, bgerror barfs because it treates + # it as TCL_RETURN no matter was -code is + dict set edict -level 0 + after idle [interp bgerror {}] [list $_value $edict] + set _bgerror_done 1 + } + + my GC + return + } + + method RegisterReactions {args} { + # Registers the specified reactions. + # args - dictionary keyed by `CLEANUP`, `FULFILLED`, `REJECTED` + # with values being the corresponding reaction callback + + lappend _reactions $args + my ScheduleReactions + return + } + + method done {{on_fulfill {}} {on_reject {}}} { + # Registers reactions to be run when the promise is settled. + # on_fulfill - command prefix for the reaction to run + # if the promise is fulfilled. + # reaction is registered. + # on_reject - command prefix for the reaction to run + # if the promise is rejected. + # Reactions are called with an additional argument which is + # the value with which the promise was settled. + # + # The command may be called multiple times to register multiple + # reactions to be run at promise settlement. If the promise was + # already settled at the time the call was made, the reactions + # are invoked immediately. In all cases, reactions are not called + # directly, but are invoked by scheduling through the event loop. + # + # The method triggers garbage collection of the object if the + # promise has been settled and any registered reactions have been + # scheduled. Applications can hold on to the object through + # appropriate use of the [ref] and [unref] methods. + # + # Note that both $on_fulfill and $on_reject may be specified + # as empty strings if no further action needs to be taken on + # settlement of the promise. If the promise is rejected, and + # no rejection reactions are registered, the error is reported + # via the Tcl `interp bgerror` facility. + + # TBD - as per the Promise/A+ spec, errors in done should generate + # a background error (unlike then). + + my RegisterReactions FULFILLED $on_fulfill REJECTED $on_reject + + #ruff + # The method does not return a value. + return + } + + method then {on_fulfill {on_reject {}}} { + # Registers reactions to be run when the promise is settled + # and returns a new [Promise] object that will be settled by the + # reactions. + # on_fulfill - command prefix for the reaction to run + # if the promise is fulfilled. If an empty string, no fulfill + # reaction is registered. + # on_reject - command prefix for the reaction to run + # if the promise is rejected. If unspecified or an empty string, + # no reject reaction is registered. + # Both reactions are passed the value with which the promise was settled. + # The reject reaction is passed an additional argument which is + # the error dictionary. + # + # The command may be called multiple times to register multiple + # reactions to be run at promise settlement. If the promise was + # already settled at the time the call was made, the reactions + # are invoked immediately. In all cases, reactions are not called + # directly, but are invoked by scheduling through the event loop. + # + # If the reaction that is invoked runs without error, its return + # value fulfills the new promise returned by the `then` method. + # If it raises an exception, the new promise will be rejected + # with the error message and dictionary from the exception. + # + # Alternatively, the reactions can explicitly invoke commands + # [then_fulfill], [then_reject] or [then_chain] to + # resolve the returned promise. In this case, the return value + # (including exceptions) from the reactions are ignored. + # + # If `on_fulfill` (or `on_reject`) is an empty string (or unspecified), + # the new promise is created and fulfilled (or rejected) with + # the same value that would have been passed in to the reactions. + # + # The method triggers garbage collection of the object if the + # promise has been settled and registered reactions have been + # scheduled. Applications can hold on to the object through + # appropriate use of the [ref] and [unref] methods. + # + # Returns a new promise that is settled by the registered reactions. + + set then_promise [[self class] new ""] + my RegisterReactions \ + FULFILLED [list ::promise::_then_reaction $then_promise FULFILLED $on_fulfill] \ + REJECTED [list ::promise::_then_reaction $then_promise REJECTED $on_reject] + return $then_promise + } + + # This could be a forward, but then we cannot document it via ruff! + method catch {on_reject} { + # Registers reactions to be run when the promise is rejected. + # on_reject - command prefix for the reaction + # reaction to run if the promise is rejected. If unspecified + # or an empty string, no reject reaction is registered. The + # reaction is called with an additional argument which is the + # value with which the promise was settled. + # This method is just a wrapper around [Promise.then] with the + # `on_fulfill` parameter defaulting to an empty string. See + # the description of that method for details. + return [my then "" $on_reject] + } + + method cleanup {cleaner} { + # Registers a reaction to be executed for running cleanup + # code when the promise is settled. + # cleaner - command prefix to run on settlement + # This method is intended to run a clean up script + # when a promise is settled. Its primary use is to avoid duplication + # of code in the `then` and `catch` handlers for a promise. + # It may also be called multiple times + # to clean up intermediate steps when promises are chained. + # + # The method returns a new promise that will be settled + # as per the following rules. + # - if the cleaner runs without errors, the returned promise + # will reflect the settlement of the promise on which this + # method is called. + # - if the cleaner raises an exception, the returned promise + # is rejected with a value consisting of the error message + # and dictionary pair. + # + # Returns a new promise that is settled based on the cleaner + set cleaner_promise [[self class] new ""] + my RegisterReactions CLEANUP [list ::promise::_cleanup_reaction $cleaner_promise $cleaner] + return $cleaner_promise + } +} + +proc promise::_then_reaction {target_promise status cmd value {edict {}}} { + # Run the specified command and fulfill/reject the target promise + # accordingly. If the command is empty, the passed-in value is passed + # on to the target promise. + + # IMPORTANT!!!! + # MUST BE CALLED FROM EVENT LOOP AT so info level must be 1. Else + # promise::then_fulfill/then_reject/then_chain will not work + # Also, Do NOT change the param name target_promise without changing + # those procs. + # Oh what a hack to get around lack of closures. Alternative would have + # been to pass an additional parameter (target_promise) + # to the application code but then that script would have had to + # carry that around. + + if {[info level] != 1} { + error "Internal error: _then_reaction not at level 1" + } + + if {[llength $cmd] == 0} { + switch -exact -- $status { + FULFILLED { $target_promise fulfill $value } + REJECTED { $target_promise reject $value $edict} + CHAINED - + PENDING - + default { + $target_promise reject "Internal error: invalid status $state" + } + } + } else { + # Invoke the real reaction code and fulfill/reject the target promise. + # Note the reaction code may have called one of the promise::then_* + # commands itself and reactions run resulting in the object being + # freed. Hence resolve using the safe* variants + # TBD - ideally we would like to execute at global level. However + # the then_* commands retrieve target_promise from level 1 (here) + # which they cannot if uplevel #0 is done. So directly invoke. + if {$status eq "REJECTED"} { + lappend cmd $value $edict + } else { + lappend cmd $value + } + if {[catch $cmd reaction_value reaction_edict]} { + safe_reject $target_promise $reaction_value $reaction_edict + } else { + safe_fulfill $target_promise $reaction_value + } + } + return +} + +proc promise::_cleanup_reaction {target_promise cleaner state value {edict {}}} { + # Run the specified cleaner and fulfill/reject the target promise + # accordingly. If the cleaner executes without error, the original + # value and state is passed on. If the cleaner executes with error + # the promise is rejected. + + if {[llength $cleaner] == 0} { + switch -exact -- $state { + FULFILLED { $target_promise fulfill $value } + REJECTED { $target_promise reject $value $edict } + CHAINED - + PENDING - + default { + $target_promise reject "Internal error: invalid state $state" + } + } + } else { + if {[catch {uplevel #0 $cleaner} err edict]} { + # Cleaner failed. Reject the target promise + $target_promise reject $err $edict + } else { + # Cleaner completed without errors, pass on the original value + if {$state eq "FULFILLED"} { + $target_promise fulfill $value + } else { + $target_promise reject $value $edict + } + } + } + return +} + +proc promise::then_fulfill {value} { + # Fulfills the promise returned by a [Promise.then] method call from + # within its reaction. + # value - the value with which to fulfill the promise + # + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - `then_fulfill`, + # [then_reject] or [then_chain]. Calling `then_fulfill` fulfills + # the promise returned by the `then` method that queued the currently + # running reaction. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + + # TBD - what if someone calls this from within a uplevel #0 ? The + # upvar will be all wrong + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_fulfill called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise fulfill $value +} + +proc promise::then_chain {promise} { + # Chains the promise returned by a [Promise.then] method call to + # another promise. + # promise - the promise to which the promise returned by [Promise.then] is + # to be chained + # + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - [then_fulfill], + # `then_reject` or [then_chain]. Calling `then_chain` chains + # the promise returned by the `then` method that queued the currently + # running reaction to $promise so that the former will be settled + # based on the latter. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_chain called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise chain $promise +} + +proc promise::then_reject {reason edict} { + # Rejects the promise returned by a [Promise.then] method call from + # within its reaction. + # reason - a message string describing the reason for the rejection. + # edict - a Tcl error dictionary + # The [Promise.then] method is a mechanism to chain asynchronous + # reactions by registering them on a promise. It returns a new + # promise which is settled by the return value from the reaction, + # or by the reaction calling one of three commands - [then_fulfill], + # `then_reject` or [then_chain]. Calling `then_reject` rejects + # the promise returned by the `then` method that queued the currently + # running reaction. + # + # It is an error to call this command from outside a reaction + # that was queued via the [Promise.then] method on a promise. + upvar #1 target_promise target_promise + if {![info exists target_promise]} { + set msg "promise::then_reject called in invalid context." + throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg + } + $target_promise reject $reason $edict +} + +proc promise::all {promises} { + # Returns a promise that fulfills or rejects when all promises + # in the $promises argument have fulfilled or any one has rejected. + # promises - a list of Promise objects + # If any of $promises rejects, then the promise returned by the + # command will reject with the same value. Otherwise, the promise + # will fulfill when all promises have fulfilled. + # The resolved value will be a list of the resolved + # values of the contained promises. + + set all_promise [Promise new [lambda {promises prom} { + set npromises [llength $promises] + if {$npromises == 0} { + $prom fulfill {} + return + } + + # Ask each promise to update us when resolved. + foreach promise $promises { + $promise done \ + [list ::promise::_all_helper $prom $promise FULFILLED] \ + [list ::promise::_all_helper $prom $promise REJECTED] + } + + # We keep track of state with a dictionary that will be + # stored in $prom with the following keys: + # PROMISES - the list of promises in the order passed + # PENDING_COUNT - count of unresolved promises + # RESULTS - dictionary keyed by promise and containing resolved value + set all_state [list PROMISES $promises PENDING_COUNT $npromises RESULTS {}] + + $prom setdata ALLPROMISES $all_state + } $promises]] + + return $all_promise +} + +proc promise::all* args { + # Returns a promise that fulfills or rejects when all promises + # in the $args argument have fulfilled or any one has rejected. + # args - list of Promise objects + # This command is identical to the all command except that it takes + # multiple arguments, each of which is a Promise object. See [all] + # for a description. + return [all $args] +} + +# Callback for promise::all. +# all_promise - the "master" promise returned by the all call. +# done_promise - the promise whose callback is being serviced. +# resolution - whether the current promise was resolved with "FULFILLED" +# or "REJECTED" +# value - the value of the currently fulfilled promise or error description +# in case rejected +# edict - error dictionary (if promise was rejected) +proc promise::_all_helper {all_promise done_promise resolution value {edict {}}} { + if {![info object isa object $all_promise]} { + # The object has been deleted. Naught to do + return + } + if {[$all_promise state] ne "PENDING"} { + # Already settled. This can happen when a tracked promise is + # rejected and another tracked promise gets settled afterwards. + return + } + if {$resolution eq "REJECTED"} { + # This promise failed. Immediately reject the master promise + # TBD - can we somehow indicate which promise failed ? + $all_promise reject $value $edict + return + } + + # Update the state of the resolved tracked promise + set all_state [$all_promise getdata ALLPROMISES] + dict set all_state RESULTS $done_promise $value + dict incr all_state PENDING_COUNT -1 + $all_promise setdata ALLPROMISES $all_state + + # If all promises resolved, resolve the all promise + if {[dict get $all_state PENDING_COUNT] == 0} { + set values {} + foreach prom [dict get $all_state PROMISES] { + lappend values [dict get $all_state RESULTS $prom] + } + $all_promise fulfill $values + } + return +} + +proc promise::race {promises} { + # Returns a promise that fulfills or rejects when any promise + # in the $promises argument is fulfilled or rejected. + # promises - a list of Promise objects + # The returned promise will fulfill and reject with the same value + # as the first promise in $promises that fulfills or rejects. + set race_promise [Promise new [lambda {promises prom} { + if {[llength $promises] == 0} { + catch {throw {PROMISE RACE EMPTYSET} "No promises specified."} reason edict + $prom reject $reason $edict + return + } + # Use safe_*, do not directly call methods since $prom may be + # gc'ed once settled + foreach promise $promises { + $promise done [list ::promise::safe_fulfill $prom ] [list ::promise::safe_reject $prom] + } + } $promises]] + + return $race_promise +} + +proc promise::race* {args} { + # Returns a promise that fulfills or rejects when any promise + # in the passed arguments is fulfilled or rejected. + # args - list of Promise objects + # This command is identical to the `race` command except that it takes + # multiple arguments, each of which is a Promise object. See [race] + # for a description. + return [race $args] +} + +proc promise::await {prom} { + # Waits for a promise to be settled and returns its resolved value. + # prom - the promise that is to be waited on + # This command may only be used from within a procedure constructed + # with the [async] command or any code invoked from it. + # + # Returns the resolved value of $prom if it is fulfilled or raises an error + # if it is rejected. + set coro [info coroutine] + if {$coro eq ""} { + throw {PROMISE AWAIT NOTCORO} "await called from outside a coroutine" + } + $prom done [list $coro success] [list $coro fail] + lassign [yieldto return -level 0] status val ropts + if {$status eq "success"} { + return $val + } else { + return -options $ropts $val + } +} + +proc promise::async {name paramdefs body} { + # Defines an procedure that will run a script asynchronously as a coroutine. + # name - name of the procedure + # paramdefs - the parameter definitions to the procedure in the same + # form as passed to the standard `proc` command + # body - the script to be executed + # + # When the defined procedure $name is called, it runs the supplied $body + # within a new coroutine. The return value from the $name procedure call + # will be a promise that will be fulfilled when the coroutine completes + # normally or rejected if it completes with an error. + # + # Note that the passed $body argument is not the body of the + # the procedure $name. Rather it is run as an anonymous procedure in + # the coroutine but in the same namespace context as $name. Thus the + # caller or the $body script must not make any assumptions about + # relative stack levels, use of `uplevel` etc. + # + # The primary purpose of this command is to make it easy, in + # conjunction with the [await] command, to wrap a sequence of asynchronous + # operations as a single computational unit. + # + # Returns a promise that will be settled with the result of the script. + if {![string equal -length 2 "$name" "::"]} { + set ns [uplevel 1 namespace current] + set name ${ns}::$name + } else { + set ns :: + } + set tmpl { + proc %NAME% {%PARAMDEFS%} { + set p [promise::Promise new [promise::lambda {real_args prom} { + coroutine ::promise::async#[info cmdcount] {*}[promise::lambda {p args} { + upvar #1 _current_async_promise current_p + set current_p $p + set status [catch [list apply [list {%PARAMDEFS%} {%BODY%} %NS%] {*}$args] res ropts] + if {$status == 0} { + $p fulfill $res + } else { + $p reject $res $ropts + } + } $prom {*}$real_args] + } [lrange [info level 0] 1 end]]] + return $p + } + } + eval [string map [list %NAME% $name \ + %PARAMDEFS% $paramdefs \ + %BODY% $body \ + %NS% $ns] $tmpl] +} + +proc promise::async_fulfill {val} { + # Fulfills a promise for an async procedure with the specified value. + # val - the value with which to fulfill the promise + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_fulfill called from outside an async context." + } + $current_p fulfill $val + return +} + +proc promise::async_reject {val {edict {}}} { + # Rejects a promise for an async procedure with the specified value. + # val - the value with which to reject the promise + # edict - error dictionary for rejection + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_reject called from outside an async context." + } + $current_p reject $val $edict + return +} + +proc promise::async_chain {prom} { + # Chains a promise for an async procedure to the specified promise. + # prom - the promise to which the async promise is to be linked. + # This command must only be called with the context of an [async] + # procedure. + # + # Returns an empty string. + upvar #1 _current_async_promise current_p + if {![info exists current_p]} { + error "async_chain called from outside an async context." + } + $current_p chain $prom + return +} + +proc promise::pfulfilled {value} { + # Returns a new promise that is already fulfilled with the specified value. + # value - the value with which to fulfill the created promise + return [Promise new [lambda {value prom} { + $prom fulfill $value + } $value]] +} + +proc promise::prejected {value {edict {}}} { + # Returns a new promise that is already rejected. + # value - the value with which to reject the promise + # edict - error dictionary for rejection + # By convention, $value should be of the format returned by + # [Promise.reject]. + return [Promise new [lambda {value edict prom} { + $prom reject $value $edict + } $value $edict]] +} + +proc promise::eventloop {prom} { + # Waits in the eventloop until the specified promise is settled. + # prom - the promise to be waited on + # The command enters the event loop in similar fashion to the + # Tcl `vwait` command except that instead of waiting on a variable + # the command waits for the specified promise to be settled. As such + # it has the same caveats as the vwait command in terms of care + # being taken in nested calls etc. + # + # The primary use of the command is at the top level of a script + # to wait for one or more promise based tasks to be completed. Again, + # similar to the vwait forever idiom. + # + # + # Returns the resolved value of $prom if it is fulfilled or raises an error + # if it is rejected. + + set varname [namespace current]::_pwait_[info cmdcount] + $prom done \ + [lambda {varname result} { + set $varname [list success $result] + } $varname] \ + [lambda {varname error ropts} { + set $varname [list fail $error $ropts] + } $varname] + vwait $varname + lassign [set $varname] status result ropts + if {$status eq "success"} { + return $result + } else { + return -options $ropts $result + } +} + +proc promise::pgeturl {url args} { + # Returns a promise that will be fulfilled when the URL is fetched. + # url - the URL to fetch + # args - arguments to pass to the `http::geturl` command + # This command invokes the asynchronous form of the `http::geturl` command + # of the `http` package. If the operation completes with a status of + # `ok`, the returned promise is fulfilled with the contents of the + # http state array (see the documentation of `http::geturl`). If the + # the status is anything else, the promise is rejected with + # the `reason` parameter to the reaction containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # with an additional key `http_state`, containing the + # contents of the http state array. + + uplevel #0 {package require http} + proc pgeturl {url args} { + set prom [Promise new [lambda {http_args prom} { + http::geturl {*}$http_args -command [promise::lambda {prom tok} { + upvar #0 $tok http_state + if {$http_state(status) eq "ok"} { + $prom fulfill [array get http_state] + } else { + if {[info exists http_state(error)]} { + set msg [lindex $http_state(error) 0] + } + if {![info exists msg] || $msg eq ""} { + set msg "Error retrieving URL." + } + catch {throw {PROMISE PGETURL} $msg} msg edict + dict set edict http_state [array get http_state] + $prom reject $msg $edict + } + http::cleanup $tok + } $prom] + } [linsert $args 0 $url]]] + return $prom + } + tailcall pgeturl $url {*}$args +} + +proc promise::ptimer {millisecs {value "Timer expired."}} { + # Returns a promise that will be fulfilled when the specified time has + # elapsed. + # millisecs - time interval in milliseconds + # value - the value with which the promise is to be fulfilled + # In case of errors (e.g. if $milliseconds is not an integer), the + # promise is rejected with the `reason` parameter set to an error + # message and the `edict` parameter set to a Tcl error dictionary. + # + # Also see [ptimeout] which is similar but rejects the promise instead + # of fulfilling it. + + return [Promise new [lambda {millisecs value prom} { + if {![string is integer -strict $millisecs]} { + # We don't allow "idle", "cancel" etc. as an argument to after + throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." + } + after $millisecs [list promise::safe_fulfill $prom $value] + } $millisecs $value]] +} + +proc promise::ptimeout {millisecs {value "Operation timed out."}} { + # Returns a promise that will be rejected when the specified time has + # elapsed. + # millisecs - time interval in milliseconds + # value - the value with which the promise is to be rejected + # In case of errors (e.g. if $milliseconds is not an integer), the + # promise is rejected with the `reason` parameter set to $value + # and the `edict` parameter set to a Tcl error dictionary. + # + # Also see [ptimer] which is similar but fulfills the promise instead + # of rejecting it. + + return [Promise new [lambda {millisecs value prom} { + if {![string is integer -strict $millisecs]} { + # We don't want to accept "idle", "cancel" etc. for after + throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." + } + after $millisecs [::promise::lambda {prom msg} { + catch {throw {PROMISE TIMER EXPIRED} $msg} msg edict + ::promise::safe_reject $prom $msg $edict + } $prom $value] + } $millisecs $value]] +} + +proc promise::pconnect {args} { + # Returns a promise that will be fulfilled when the socket connection + # is completed. + # args - arguments to be passed to the Tcl `socket` command + # This is a wrapper for the async version of the Tcl `socket` command. + # If the connection completes, the promise is fulfilled with the + # socket handle. + # In case of errors (e.g. if the address cannot be fulfilled), the + # promise is rejected with the `reason` parameter containing the + # error message and the `edict` parameter containing the Tcl error + # dictionary. + # + return [Promise new [lambda {so_args prom} { + set so [socket -async {*}$so_args] + fileevent $so writable [promise::lambda {prom so} { + fileevent $so writable {} + set err [chan configure $so -error] + if {$err eq ""} { + $prom fulfill $so + } else { + catch {throw {PROMISE PCONNECT FAIL} $err} err edict + $prom reject $err $edict + } + } $prom $so] + } $args]] +} + +proc promise::_read_channel {prom chan data} { + set newdata [read $chan] + if {[string length $newdata] || ![eof $chan]} { + append data $newdata + fileevent $chan readable [list [namespace current]::_read_channel $prom $chan $data] + return + } + + # EOF + set code [catch { + # Need to make the channel blocking else no error is returned + # on the close + fileevent $chan readable {} + fconfigure $chan -blocking 1 + close $chan + } result edict] + if {$code} { + safe_reject $prom $result $edict + } else { + safe_fulfill $prom $data + } +} + +proc promise::pexec {args} { + # Runs an external program and returns a promise for its output. + # args - program and its arguments as passed to the Tcl `open` call + # for creating pipes + # If the program runs without errors, the promise is fulfilled by its + # standard output content. Otherwise + # promise is rejected. + # + # Returns a promise that will be settled by the result of the program + return [Promise new [lambda {open_args prom} { + set chan [open |$open_args r] + fconfigure $chan -blocking 0 + fileevent $chan readable [list promise::_read_channel $prom $chan ""] + } $args]] +} + +proc promise::safe_fulfill {prom value} { + # Fulfills the specified promise. + # prom - the [Promise] object to be fulfilled + # value - the fulfillment value + # This is a convenience command that checks if $prom still exists + # and if so fulfills it with $value. + # + # Returns 0 if the promise does not exist any more, else the return + # value from its [fulfill][Promise.fulfill] method. + if {![info object isa object $prom]} { + # The object has been deleted. Naught to do + return 0 + } + return [$prom fulfill $value] +} + +proc promise::safe_reject {prom value {edict {}}} { + # Rejects the specified promise. + # prom - the [Promise] object to be fulfilled + # value - see [Promise.reject] + # edict - see [Promise.reject] + # This is a convenience command that checks if $prom still exists + # and if so rejects it with the specified arguments. + # + # Returns 0 if the promise does not exist any more, else the return + # value from its [reject][Promise.reject] method. + if {![info object isa object $prom]} { + # The object has been deleted. Naught to do + return + } + $prom reject $value $edict +} + +proc promise::ptask {script} { + # Creates a new Tcl thread to run the specified script and returns + # a promise for the script results. + # script - script to run in the thread + # Returns a promise that will be settled by the result of the script + # + # The `ptask` command runs the specified script in a new Tcl + # thread. The promise returned from this command will be fulfilled + # with the result of the script if it completes + # successfully. Otherwise, the promise will be rejected with an + # with the `reason` parameter containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # from the script failure. + # + # Note that $script is a standalone script in that it is executed + # in a new thread with a virgin Tcl interpreter. Any packages used + # by $script have to be explicitly loaded, variables defined in the + # the current interpreter will not be available in $script and so on. + # + # The command requires the Thread package to be loaded. + + uplevel #0 package require Thread + proc [namespace current]::ptask script { + return [Promise new [lambda {script prom} { + set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { + set retcode [catch {%SCRIPT%} result edict] + if {$retcode == 0 || $retcode == 2} { + # ok or return + set response [list ::promise::safe_fulfill %PROM% $result] + } else { + set response [list ::promise::safe_reject %PROM% $result $edict] + } + thread::send -async %TID% $response + }] + thread::create $thread_script + } $script]] + } + tailcall [namespace current]::ptask $script +} + +proc promise::pworker {tpool script} { + # Runs a script in a worker thread from a thread pool and + # returns a promise for the same. + # tpool - thread pool identifier + # script - script to run in the worker thread + # Returns a promise that will be settled by the result of the script + # + # The Thread package allows creation of a thread pool with the + # `tpool create` command. The `pworker` command runs the specified + # script in a worker thread from a thread pool. The promise + # returned from this command will be fulfilled with the result of + # the script if it completes successfully. + # Otherwise, the promise will be rejected with an + # with the `reason` parameter containing the error message + # and the `edict` parameter containing the Tcl error dictionary + # from the script failure. + # + # Note that $script is a standalone script in that it is executed + # in a new thread with a virgin Tcl interpreter. Any packages used + # by $script have to be explicitly loaded, variables defined in the + # the current interpreter will not be available in $script and so on. + + # No need for package require Thread since if tpool is passed to + # us, Thread must already be loaded + return [Promise new [lambda {tpool script prom} { + set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { + set retcode [catch {%SCRIPT%} result edict] + if {$retcode == 0 || $retcode == 2} { + set response [list ::promise::safe_fulfill %PROM% $result] + } else { + set response [list ::promise::safe_reject %PROM% $result $edict] + } + thread::send -async %TID% $response + }] + tpool::post -detached -nowait $tpool $thread_script + } $tpool $script]] +} + +if {0} { + package require http + proc checkurl {url} { + set prom [promise::Promise new [promise::lambda {url prom} { + http::geturl $url -method HEAD -command [promise::lambda {prom tok} { + upvar #0 $tok http_state + $prom fulfill [list $http_state(url) $http_state(status)] + ::http::cleanup $tok + } $prom] + } $url]] + return $prom + } + + proc checkurls {urls} { + return [promise::all [lmap url $urls {checkurl $url}]] + } + + [promise::all [ + list [ + promise::ptask {expr 1+1} + ] [ + promise::ptask {expr 2+2} + ] + ]] done [promise::lambda val {puts [tcl::mathop::* {*}$val]}] +} + +package provide promise [promise::version] + +if {[info exists ::argv0] && + [file tail [info script]] eq [file tail $::argv0]} { + set filename [file tail [info script]] + if {[llength $::argv] == 0} { + puts "Usage: [file tail [info nameofexecutable]] $::argv0 dist|install|tm|version" + exit 1 + } + switch -glob -- [lindex $::argv 0] { + ver* { puts [promise::version] } + tm - + dist* { + if {[file extension $filename] ne ".tm"} { + set dir [file join [file dirname [info script]] .. build] + file mkdir $dir + file copy -force [info script] [file join $dir [file rootname $filename]-[promise::version].tm] + } else { + error "Cannot create distribution from a .tm file" + } + } + install { + # Install in first native file system that exists on search path + foreach path [tcl::tm::path list] { + if {[lindex [file system $path] 0] eq "native"} { + set dir $path + if {[file isdirectory $path]} { + break + } + # Else keep looking + } + } + if {![file exists $dir]} { + file mkdir $dir + } + if {[file extension $filename] eq ".tm"} { + # We already are a .tm with version number + set target $filename + } else { + set target [file rootname $filename]-[promise::version].tm + } + file copy -force [info script] [file join $dir $target] + } + default { + puts stderr "Unknown option/command \"[lindex $::argv 0]\"" + exit 1 + } + } +} diff --git a/src/project_layouts/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 new file mode 100644 index 00000000..68a14411 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk-0.1.tm @@ -0,0 +1,8187 @@ +#Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk. +#Built on Tcl of course - because it's the most powerful piece of under-appreciated and alternate-thinking engineering you can plug into. + + +namespace eval punk { + proc lazyload {pkg} { + package require zzzload + if {[package provide $pkg] eq ""} { + zzzload::pkg_require $pkg + } + } + #lazyload twapi ? + + catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later + + variable can_exec_windowsapp + set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed + variable windowsappdir + set windowsappdir "" + variable cmdexedir + set cmdexedir "" + + proc sync_package_paths_script {} { + #the tcl::tm namespace doesn't exist until one of the tcl::tm commands + #is run. (they are loaded via ::auto_index triggering load of tm.tcl) + #we call tcl::tm::list to trigger the initial set of tm paths before + #we can override it, otherwise our changes will be lost + #REVIEW - won't work on safebase interp where paths are mapped to {$p(:x:)} etc + return "\ + apply {{ap tmlist} { + set ::auto_path \$ap + tcl::tm::list + set ::tcl::tm::paths \$tmlist + }} {$::auto_path} {[tcl::tm::list]} + " + } + + proc rehash {{refresh 0}} { + global auto_execs + if {!$refresh} { + unset -nocomplain auto_execs + } else { + set names [array names auto_execs] + unset -nocomplain auto_execs + foreach nm $names { + auto_execok_windows $nm + } + } + return + } + + + proc ::punk::auto_execok_original name [info body ::auto_execok] + variable better_autoexec + + #set better_autoexec 0 ;#use this var via better_autoexec only + #proc ::punk::auto_execok_windows name { + # ::punk::auto_execok_original $name + #} + + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + + set has_commandstack [expr {![catch {package require commandstack}]}] + if {$has_commandstack} { + if {[catch { + package require punk::packagepreference + } errM]} { + catch {puts stderr "Failed to load punk::packagepreference"} + } + catch punk::packagepreference::install + } else { + # + } + + if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} { + + #still a caching version of auto_execok - but with proper(fixed) search order + + #set b [info body ::auto_execok] + #proc ::auto_execok_original name $b + + proc better_autoexec {{onoff ""}} { + variable better_autoexec + if {$onoff eq ""} { + return $better_autoexec + } + if {![string is boolean -strict $onoff]} { + error "better_autoexec argument 'onoff' must be a boolean, received: $onoff" + } + if {$onoff && ($onoff != $better_autoexec)} { + puts "Turning on better_autoexec - search PATH first then extension" + set better_autoexec 1 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_better $name + } + punk::rehash + } elseif {!$onoff && ($onoff != $better_autoexec)} { + puts "Turning off better_autoexec - search extension then PATH" + set better_autoexec 0 + proc ::punk::auto_execok_windows name { + ::punk::auto_execok_original $name + } + punk::rehash + } else { + puts "no change" + } + } + #better_autoexec $better_autoexec ;#init to default + + + proc auto_execok_better name { + global auto_execs env tcl_platform + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + #puts stdout "[a+ red]...[a]" + set auto_execs($name) "" + + set shellBuiltins [list assoc cls copy date del dir echo erase exit ftype \ + md mkdir mklink move rd ren rename rmdir start time type ver vol] + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + if {[string tolower $name] in $shellBuiltins} { + # When this is command.com for some reason on Win2K, Tcl won't + # exec it unless the case is right, which this corrects. COMSPEC + # may not point to a real file, so do the check. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext $execExtensions { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + return "" + } + + #change1 + #set path "[file dirname [info nameofexecutable]];.;" + set path "[file dirname [info nameofexecutable]];" + + if {[info exists env(SystemRoot)]} { + set windir $env(SystemRoot) + } elseif {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + append path "$windir/system32;$windir/system;$windir;" + } + + foreach var {PATH Path path} { + if {[info exists env($var)]} { + append path ";$env($var)" + } + } + + #change2 + set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + foreach dir [split $path {;}] { + #set dir [file normalize $dir] + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} + + foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] { + set file [file join $dir $match] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + } + + #foreach ext $execExtensions { + #unset -nocomplain checked + #foreach dir [split $path {;}] { + # # Skip already checked directories + # if {[info exists checked($dir)] || ($dir eq "")} { + # continue + # } + # set checked($dir) {} + # set file [file join $dir ${name}${ext}] + # if {[file exists $file] && ![file isdirectory $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + #} + return "" + } + + + + #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? + #what if we create another interp and use the same ::auto_execs? The appdir won't be detected. + #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed + + + + #winget is installed on all modern windows and is an example of the problem this addresses + #we target apps with same location + + #the main purpose of this override is to support windows app executables (installed as 'reparse points') + #for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac + #versions prior to this will use cmd.exe to resolve the links + set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name { + #set windowsappdir "%appdir%" + upvar ::punk::can_exec_windowsapp can_exec_windowsapp + upvar ::punk::windowsappdir windowsappdir + upvar ::punk::cmdexedir cmdexedir + + if {$windowsappdir eq ""} { + #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' + #Tcl (2025) can't exec when given a path to these 0KB files + #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps + if {!([info exists ::env(LOCALAPPDATA)] && + [file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} { + #should be unlikely to get here - unless LOCALAPPDATA missing + set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]] + catch {puts stderr "(resolved winget by search)"} + } else { + set windowsappdir [file dirname $testapp] + } + } + + #set default_auto [$COMMANDSTACKNEXT $name] + set default_auto [::punk::auto_execok_windows $name] + #if {$name ni {cmd cmd.exe}} { + # unset -nocomplain ::auto_execs + #} + + if {$default_auto eq ""} { + return + } + set namedir [file dirname [lindex $default_auto 0]] + + if {$namedir eq $windowsappdir} { + if {$can_exec_windowsapp eq "unknown"} { + if {[catch {exec [file join $windowsappdir winget.exe] --version}]} { + set can_exec_windowsapp 0 + } else { + set can_exec_windowsapp 1 + } + } + if {$can_exec_windowsapp} { + return [file join $windowsappdir $name] + } + if {$cmdexedir eq ""} { + #cmd.exe very unlikely to move + set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] + #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index + #anyway.. it has other side effects (affects auto_load) + } + return "[file join $cmdexedir cmd.exe] /c $name" + } + return $default_auto + }] + + + } + +} + + + +#repltelemetry cooperation with other packages such as shellrun +#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists +namespace eval punk { + variable repltelemetry_emmitters + #don't stomp.. even if something created this namespace in advance and is 'cooperating' a bit early + if {![info exists repltelemetry_emitters]} { + set repltelemetry_emmitters [list] + } +} + +namespace eval punk::pipecmds { + #where to install proc/compilation artifacts for pieplines + namespace export * +} +namespace eval punk::pipecmds::split_patterns {} +namespace eval punk::pipecmds::split_rhs {} +namespace eval punk::pipecmds::var_classify {} +namespace eval punk::pipecmds::destructure {} +namespace eval punk::pipecmds::insertion {} + + +#globals... some minimal global var pollution +#punk's official silly test dictionary +set punk_testd [dict create \ + a0 a0val \ + b0 [dict create \ + a1 b0a1val \ + b1 b0b1val \ + c1 b0c1val \ + d1 b0d1val \ + ] \ + c0 [dict create] \ + d0 [dict create \ + a1 [dict create \ + a2 d0a1a2val \ + b2 d0a1b2val \ + c2 d0a1c2val \ + ] \ + b1 [dict create \ + a2 [dict create \ + a3 d0b1a2a3val \ + b3 d0b1a2b3val \ + ] \ + b2 [dict create \ + a3 d0b1b2a3val \ + bananas "in pyjamas" \ + c3 [dict create \ + po "in { }" \ + b4 ""\ + c4 "can go boom" \ + ] \ + d3 [dict create \ + a4 "-paper -cuts" \ + ] \ + e3 [dict create] \ + ] \ + ] \ + ] \ + e0 "multi\nline"\ + ] +#test dict 2 - uniform structure and some keys with common prefixes for glob matching +set punk_testd2 [dict create \ + a0 [dict create \ + b1 {a b c}\ + b2 {a b c d}\ + x1 {x y z 1 2}\ + y2 {X Y Z 1 2}\ + z1 {k1 v1 k2 v2 k3 v3}\ + ] \ + a1 [dict create \ + b1 {a b c}\ + b2 {a b c d}\ + x1 {x y z 1 2}\ + y2 {X Y Z 1 2}\ + z1 {k1 v1 k2 v2 k3 v3}\ + ] \ + b1 [dict create \ + b1 {a b c}\ + b2 {a b c d}\ + x1 {x y z 1 2}\ + y2 {X Y Z 1 2}\ + z1 {k1 v1 k2 v2 k3 v3}\ + ] \ +] + +#impolitely cooperative with punk repl - todo - tone it down. +#namespace eval ::punk::repl::codethread { +# variable running 0 +#} +package require punk::lib ;# subdependency punk::args +package require punk::ansi +if {![llength [info commands ::ansistring]]} { + namespace import punk::ansi::ansistring +} +#require aliascore after punk::lib & punk::ansi are loaded +package require punk::aliascore ;#mostly punk::lib aliases +punk::aliascore::init -force 1 + +package require punk::repl::codethread +package require punk::config +#package require textblock +package require punk::console ;#requires Thread +package require punk::ns +package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems +package require punk::repo +package require punk::du +package require punk::mix::base + +namespace eval punk { + # -- --- --- + #namespace import ::control::assert ;#according to tcllib doc - assert can be enabled/disabled per namespace + # using control::control assert enabled within a namespace for which ::control::assert wasn't imported can produce surprising results. + #e.g setting to zero may keep asserts enabled - (e.g if the assert command is still available due to namespace path etc) - but.. querying the enabled status may show zero even in the parent namespace where asserts also still work. + #package require control + #control::control assert enabled 1 + + #We will use punk::assertion instead + + package require punk::assertion + if {[catch {namespace import ::punk::assertion::assert} errM]} { + catch { + puts stderr "punk error importing punk::assertion::assert\n$errM" + puts stderr "punk::a* commands:[info commands ::punk::a*]" + } + } + punk::assertion::active on + # -- --- --- + + interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system + if {[catch { + package require pattern + } errpkg]} { + catch {puts stderr "Failed to load package pattern error: $errpkg"} + } + package require shellfilter + package require punkapp + package require funcl + + package require struct::list + package require fileutil + #package require punk::lib + + #NOTE - always call debug.xxx with braced message instead of double-quoted (unless specifically intending to do double-subtition) + #(or $ within values will be substituted, causing an extra error message if the var doesn't exist - which it quite possibly doesn't) + package require debug + + debug define punk.unknown + debug define punk.pipe + debug define punk.pipe.var + debug define punk.pipe.args + debug define punk.pipe.rep ;#string/list representation with tcl::unsupported::representation + debug define punk.pipe.compile ;#info about when we compile pipeline components into procs etc + + + #----------------------------------- + # todo - load initial debug state from config + debug off punk.unknown + debug level punk.unknown 1 + debug off punk.pipe + debug level punk.pipe 4 + debug off punk.pipe.var + debug level punk.pipe.var 4 + debug off punk.pipe.args + debug level punk.pipe.args 3 + debug off punk.pipe.rep 2 + debug off punk.pipe.compile + debug level punk.pipe.compile 2 + + + debug header "dbg> " + + + variable last_run_display [list] + + + #variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$} + + + + #----------------------------------------------------------------------------------- + #strlen is important for testing issues with string representationa and shimmering. + #This specific implementation with append (as at 2023-09) is designed to ensure the original str representation isn't changed + #It may need to be reviewed with different Tcl versions in case the append empty string is 'optimised/tuned' in some way that affects the behaviour + proc strlen {str} { + append str2 $str {} + string length $str2 + } + #----------------------------------------------------------------------------------- + + #get a copy of the item without affecting internal rep + proc objclone {obj} { + append obj2 $obj {} + } + proc set_clone {varname obj} { + #maintenance: also punk::lib::set_clone + #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + + interp alias "" strlen "" ::punk::strlen + interp alias "" str_len "" ::punk::strlen + interp alias "" objclone "" ::punk::objclone + #proc ::strlen {str} { + # string length [append str2 $str {}] + #} + #proc ::objclone {obj} { + # append obj2 $obj {} + #} + #----------------------------------------------------------------------------------- + #order of arguments designed for pipelining + #review - 'piper_' prefix is a naming convention for functions that are ordered for tail-argument pipelining + #piper_ function names should read intuitively when used in a pipeline with tail argument supplied by the pipeline - but may seem reversed when using standalone. + proc piper_append {new base} { + append base $new + } + interp alias "" piper_append "" ::punk::piper_append + proc piper_prepend {new base} { + append new $base + } + interp alias "" piper_prepend "" ::punk::piper_prepend + + proc ::punk::K {x y} { return $x} + + proc stacktrace {} { + set stack "Stack trace:\n" + for {set i 1} {$i < [info level]} {incr i} { + set lvl [info level -$i] + set pname [lindex $lvl 0] + append stack [string repeat " " $i]$pname + + if {![catch {info args $pname} pargs]} { + foreach value [lrange $lvl 1 end] arg $pargs { + + if {$value eq ""} { + if {$arg != 0} { + info default $pname $arg value + } + } + append stack " $arg='$value'" + } + } else { + append stack " !unknown vars for $pname" + } + + append stack \n + } + return $stack + } + + #review - there are various type of uuid - we should use something consistent across platforms + #twapi is used on windows because it's about 5 times faster - but is this more important than consistency? + #twapi is much slower to load in the first place (e.g 75ms vs 6ms if package names already loaded) - so for oneshots tcllib uuid is better anyway + #(counterpoint: in the case of punk - we currently need twapi anyway on windows) + #does tcllib's uuid use the same mechanisms on different platforms anyway? + proc ::punk::uuid {} { + set has_twapi 0 + if 0 { + if {"windows" eq $::tcl_platform(platform)} { + if {![catch { + set loader [zzzload::pkg_wait twapi] + } errM]} { + if {$loader in [list failed loading]} { + catch {puts stderr "Unexpected problem during thread-load of pkg twapi - zzload::pkg_wait returned $loader"} + } + } else { + package require twapi + } + if {[package provide twapi] ne ""} { + set has_twapi 1 + } + } + } + if {!$has_twapi} { + if {[catch {package require uuid} errM]} { + error "Unable to load a package for uuid on this platform. Try installing tcllib's uuid (any platform) - or twapi for windows" + } + return [uuid::uuid generate] + } else { + return [twapi::new_uuid] + } + } + + #get last command result that was run through the repl + proc ::punk::get_runchunk {args} { + set argd [punk::args::get_dict { + @id -id ::punk::get_runchunk + @opts + -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] + } + set sorted [lsort -index 0 -integer $sortlist] + set chunkname [lindex $sorted end-1 1] + set runlist [tsv::get repl $chunkname] + #puts stderr "--$runlist" + if {![llength $runlist]} { + return "" + } else { + return [lindex [lsearch -inline -index 0 $runlist result] 1] + } + } + interp alias {} _ {} ::punk::get_runchunk + + + proc ::punk::var {varname {= _=.=_} args} { + upvar $varname the_var + switch -exact -- ${=} { + = { + if {[llength $args] > 1} { + set the_var $args + } else { + set the_var [lindex $args 0] + } + } + .= { + if {[llength $args] > 1} { + set the_var [uplevel 1 $args] + } else { + set the_var [uplevel 1 [lindex $args 0]] + } + } + _=.=_ { + set the_var + } + default { + set the_var [list ${=} {*}$args] + } + } + } + proc src {args} { + #based on wiki.. https://wiki.tcl-lang.org/page/source+with+args + #added support for ?-encoding name? and other options of Tcl source command under assumption they come pairs before the filename + # review? seems unlikely source command will ever accept solo options. It would make complete disambiguation impossible when passing additional args as we are doing here. + set cmdargs [list] + set scriptargs [list] + set inopts 0 + set i 0 + foreach a $args { + if {$i eq [llength $args]-1} { + #reached end without finding end of opts + #must be file - even if it does match -* ? + break + } + if {!$inopts} { + if {[string match -* $a]} { + set inopts 1 + } else { + #leave loop at first nonoption - i should be index of file + break + } + } else { + #leave for next iteration to check + set inopts 0 + } + incr i + } + set cmdargs [lrange $args 0 $i] + set scriptargs [lrange $args $i+1 end] + set argv $::argv + set argc $::argc + set ::argv $scriptargs + set ::argc [llength $scriptargs] + set code [catch {uplevel [list source {*}$cmdargs]} return] + set ::argv $argv + set ::argc $argc + return -code $code $return + } + #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 ""}} { + upvar $vname v + if {[array exists $vname]} { + error "can't read \"$vname\": variable is array" + } + if {[catch {set v} err]} { + error "can't read \"$vname\": no such variable" + } + set inf [shellfilter::list_element_info [list $v]] + set inf [dict get $inf 0] + if {$flag eq "-v"} { + return $inf + } + + set output [dict create] + dict set output wouldbrace [dict get $inf wouldbrace] + dict set output wouldescape [dict get $inf wouldescape] + dict set output head_tail_names [dict get $inf head_tail_names] + dict set output len [dict get $inf len] + return $output + } + + #review - extending core commands could be a bit intrusive...although it can make sense in a pipeline. + #e.g contrived pipeline example to only allow setting existing keys + ## .= @head.= list {a aaa b bbb c ccc} |d,dkeys@keys> |> &true.= {is_list_all_in_list $nkeys $dkeys} |> {dict modify d {*}$new} |> &true.= {is_list_all_ni_list $nkeys $dkeys} |> {dict modify d {*}$new} " "<"] ;# (> 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 ^# + #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 + #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 prevc "" + foreach c [split $varspecs ""] { + if {$in_brackets} { + append token $c + if {$c eq ")"} { + set in_brackets 0 + } + } 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] + 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 + } elseif {$c eq "("} { + set in_brackets 1 + } + } + } + set prevc $c + 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] + } + return $varlist + } + proc _split_var_key_at_unbracketed_comma1 {varspecs} { + set varlist [list] + set var_terminals [list "@" "/" "#" "!"] + set in_brackets 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 + foreach c [split $varspecs ""] { + if {$in_brackets} { + if {$c eq ")"} { + set in_brackets 0 + } + append token $c + } else { + if {$c eq ","} { + if {$first_term > -1} { + set v [string range $token 0 $first_term-1] + set k [string range $token $first_term end] ;#key section includes the terminal char + lappend varlist [list $v $k] + } else { + lappend varlist [list $token ""] + } + set token "" + set token_index -1 ;#reduce by 1 because , not included in next token + set first_term -1 + } else { + if {$first_term == -1} { + if {$c in $var_terminals} { + set first_term $token_index + } + } + append token $c + if {$c eq "("} { + set in_brackets 1 + } + } + } + incr token_index + } + if {[string length $token]} { + if {$first_term > -1} { + set v [string range $token 0 $first_term-1] + set k [string range $token $first_term end] ;#key section includes the terminal char + lappend varlist [list $v $k] + } else { + lappend varlist [list $token ""] + } + } + return $varlist + } + + proc fp_restructure {selector data} { + if {$selector eq ""} { + fun=.= {val $input} and always break + set lhs "" + set rhs "" + #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? + foreach index $subindices { + set subpath [join [lrange $subindices 0 $i_keyindex] /] + set lhs $subpath + set assigned "" + set get_not 0 + set already_assigned 0 + set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. + #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. + #todo - see if 'string is list' improved in tcl9 vs catch {llength $list} + switch -exact -- $index { + # { + set active_key_type "list" + if {![catch {llength $leveldata} assigned]} { + set already_assigned 1 + } else { + set action ?mismatch-not-a-list + break + } + } + ## { + set active_key_type "dict" + if {![catch {dict size $leveldata} assigned]} { + set already_assigned 1 + } else { + set action ?mismatch-not-a-dict + break + } + } + #? { + #review - compare to %# ????? + #seems to be unimplemented ? + set assigned [string length $leveldata] + set already_assigned 1 + } + @ { + upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position + set active_key_type "list" + #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey + #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 + #while x@,y@.= is reasonably handy - especially for args e.g $len} { + set action ?mismatch-list-index-out-of-range + break + } + set assigned [lindex $leveldata $index] + set already_assigned 1 + } + @@ - @?@ - @??@ { + set active_key_type "dict" + + #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc + #x@@ = a {x y} + #x@@/@0 = a + #x@@/@1 = x y + #x@@/a = a {x y} + # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. + # (note that ?@ forms a different subpath - so can be used to test match prior to @@ without affecting the index) + # It is analogous to v1@,v2@ for lists. + # @pairs is more useful for repeated operations + + # + #set subpath [join [lrange $subindices 0 $i_keyindex] /] + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set next_this_level [incr v_dict_idx($subpath)] + set keyindex [expr {$next_this_level -1}] + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + if {$index eq "@?@"} { + set assigned [dict get $leveldata $k] + } else { + set assigned [list $k [dict get $leveldata $k]] + } + } else { + if {$index eq "@@"} { + set action ?mismatch-dict-index-out-of-range + break + } else { + set assigned [list] + } + } + set already_assigned 1 + } + default { + switch -glob -- $index { + @@* { + set active_key_type "dict" + set key [string range $index 2 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [dict get $leveldata $key] + } else { + set action ?mismatch-dict-key-not-found + break + } + set already_assigned 1 + } + {@\?@*} { + set active_key_type "dict" + set key [string range $index 3 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [dict get $leveldata $key] + } else { + set assigned [list] + } + set already_assigned 1 + } + {@\?\?@*} { + set active_key_type "dict" + set key [string range $index 4 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [list $key [dict get $leveldata $key]] + } else { + set assigned [list] + } + set already_assigned 1 + } + @* { + set active_key_type "list" + set do_bounds_check 1 + set index [string trimleft $index @] + } + default { + # + } + } + + if {!$already_assigned} { + if {[string match "not-*" $index] && $active_key_type in [list "" "list"]} { + #e.g not-0-end-1 not-end-4-end-2 + set get_not 1 + #cherry-pick some easy cases, and either assign, or re-map to corresponding index + switch -- $index { + not-tail { + set active_key_type "list" + set assigned [lindex $leveldata 0]; set already_assigned 1 + } + not-head { + set active_key_type "list" + #set selector "tail"; set get_not 0 + set assigned [lrange $leveldata 1 end]; set already_assigned 1 + } + not-end { + set active_key_type "list" + set assigned [lrange $leveldata 0 end-1]; set already_assigned 1 + } + default { + #trim off the not- and let the remaining index handle based on get_not being 1 + set index [string range $index 4 end] + } + } + } + } + } + } + + if {!$already_assigned} { + + #keyword 'pipesyntax' at beginning of error message + set listmsg "pipesyntax Unable to interpret subindex $index\n" + append listmsg "selector: '$selector'\n" + append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" + append listmsg "Additional accepted keywords include: head tail\n" + append listmsg "Use var@@key to treat value as a dict and retrieve element at key" + + + #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against + #need to set a corresponding action + if {$active_key_type in [list "" "list"]} { + set active_key_type "list" + #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) + if {$index eq "0"} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lindex $leveldata 0] + } elseif {$index eq "head"} { + #NOTE: /@head and /head both do bounds check. This is intentional + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$len == 0} { + set action ?mismatch-list-index-out-of-range-empty + break + } + #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax + set assigned [lindex $leveldata 0] + } elseif {$index eq "end"} { + # @end /end + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$do_bounds_check && $len < 1} { + set action ?mismatch-list-index-out-of-range + } + set assigned [lindex $leveldata end] + } elseif {$index eq "tail"} { + #NOTE: /@tail and /tail both do bounds check. This is intentional. + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list + #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. + #In this way tail is different to @1-end + if {$len == 0} { + set action ?mismatch-list-index-out-of-range + break + } + set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero. + } elseif {$index eq "anyhead"} { + # @anyhead + #allow returning of head or nothing if empty list + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lindex $leveldata 0] + } elseif {$index eq "anytail"} { + # @anytail + #allow returning of tail or nothing if empty list + #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lrange $leveldata 1 end] + } elseif {$index eq "init"} { + # @init + #all but last element - same as haskell 'init' + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lrange $leveldata 0 end-1] + } elseif {$index eq "list"} { + # @list + #allow returning of entire list even if empty + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned $leveldata + } elseif {$index eq "raw"} { + #no list checking.. + set assigned $leveldata + } elseif {$index eq "keys"} { + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set assigned [dict keys $leveldata] + } elseif {$index eq "values"} { + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set assigned [dict values $leveldata] + } elseif {$index eq "pairs"} { + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + #set assigned [dict values $leveldata] + set pairs [list] + tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} + set assigned [lindex [list $pairs [unset pairs]] 0] + } elseif {[string is integer -strict $index]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + # only check if @ was directly in original index section + if {$do_bounds_check && ($index+1 > $len || $index < 0)} { + set action ?mismatch-list-index-out-of-range + break + } + if {$get_not} { + #already handled not-0 + set assigned [lreplace $leveldata $index $index] + } else { + set assigned [lindex $leveldata $index] + } + } elseif {[string first "end" $index] >=0} { + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #leave the - from the end- as part of the offset + set offset [expr $endspec] ;#don't brace! + if {$do_bounds_check && ($offset > 0 || abs($offset) >= $len)} { + set action ?mismatch-list-index-out-of-range + break + } + if {$get_not} { + set assigned [lreplace $leveldata $index $index] + } else { + set assigned [lindex $leveldata $index] + } + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$do_bounds_check && [string is integer -strict $start]} { + if {$start+1 > $len || $start < 0} { + set action ?mismatch-list-index-out-of-range + break + } + } elseif {$start eq "end"} { + #ok + } elseif {$do_bounds_check} { + set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [expr $startoffset] ;#don't brace! + if {$startoffset > 0 || abs($startoffset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + } + if {$do_bounds_check && [string is integer -strict $end]} { + if {$end+1 > $len || $end < 0} { + set action ?mismatch-list-index-out-of-range + break + } + } elseif {$end eq "end"} { + #ok + } elseif {$do_bounds_check} { + set endoffset [string range $end 3 end] ;#include the - from end- + set endoffset [expr $endoffset] ;#don't brace! + if {$endoffset > 0 || abs($endoffset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + } + if {$get_not} { + set assigned [lreplace $leveldata $start $end] + } else { + set assigned [lrange $leveldata $start $end] + } + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } elseif {[string first - $index] > 0} { + puts "====> index:$index leveldata:$leveldata" + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #handle pure int-int ranges separately + set testindex [string map [list - "" + ""] $index] + if {[string is digit -strict $testindex]} { + #don't worry about leading - negative value for indices not valid anyway + set parts [split $index -] + if {[llength $parts] != 2} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + lassign $parts start end + if {$start+1 > $len || $end+1 > $len} { + set action ?mismatch-not-a-list + break + } + if {$get_not} { + set assigned [lreplace $leveldata $start $end] + } else { + set assigned [lrange $leveldata $start $end] + } + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + + } else { + #keyword 'pipesyntax' at beginning of error message + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } else { + #treat as dict key + set active_key_type "dict" + if {[dict exists $leveldata $index]} { + set assigned [dict get $leveldata $index] + } else { + set action ?mismatch-dict-key-not-found + break + } + + } + } + set leveldata $assigned + set rhs $leveldata + #don't break on empty data - operations such as # and ## can return 0 + #if {![llength $leveldata]} { + # break + #} + incr i_keyindex + } + #puts stdout "----> destructure rep leveldata: [rep $leveldata]" + #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" + + #maintain key order - caller unpacks using lassign + return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] + + } + #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a more efficient tcl script + proc destructure_func {selector data} { + #puts stderr ".d." + set selector [string trim $selector /] + #upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position + #upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position + + #map some problematic things out of the way in a manner that maintains some transparency + #e.g glob chars ? * in a command name can make testing using {[info commands $cmd] ne ""} produce spurious results - requiring a stricter (and slower) test such as {$cmd in [info commands $cmd]} + #The selector forms part of the proc name + set selector_safe [string map [list ? * {$} "" "\x1b\[" "\x1b\]" {[} {]} :: {;} " " \t \n \r ] $selector] + + set cmdname ::punk::pipecmds::destructure::_$selector_safe + if {[info commands $cmdname] ne ""} { + return [$cmdname $data] ;# note upvar 2 for stateful v_list_idx to be resolved in _multi_bind_result context + } + + set leveldata $data + set body [destructure_func_build_procbody $cmdname $selector $data] + + puts stdout ---- + puts stderr "proc $cmdname {leveldata} {" + puts stderr $body + puts stderr "}" + puts stdout --- + proc $cmdname {leveldata} $body + #eval $script ;#create the proc + debug.punk.pipe.compile {proc $cmdname} 4 + #return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] + #use return - script has upvar 2 for v_list_idx to be resolved in _multi_bind_result context + return [$cmdname $data] + } + + #Builds a *basic* function to do the destructuring. + #This is simply a set of steps to destructure each level of the data based on the hierarchical selector. + #It just uses intermediate variables and adds some comments to the code to show the indices used at each point. + #This may be useful in the long run as a debug/fallback mechanism - but ideally we should be building a more efficient script. + proc destructure_func_build_procbody {cmdname selector data} { + set script "" + #place selector in comment in script only - if there is an error in selector we pick it up when building the script. + #The script itself should only be returning errors in its action key of the result dictionary + append script \n [string map [list $selector] {# set selector {}}] + set subindices [split $selector /] + append script \n [string map [list [list $subindices]] {# set subindices }] + set action ?match ;#default assumption. Alternatively set to ?mismatch or ?mismatch- and always break + append script \n {set action ?match} + #append script \n {set assigned ""} ;#review + set active_key_type "" + append script \n {# set active_key_type ""} + set lhs "" + #append script \n [tstr {set lhs ${{$lhs}}}] + append script \n {set lhs ""} + set rhs "" + append script \n {set rhs ""} + + set INDEX_OPERATIONS {} ;#caps to make clear in templates that this is substituted from script building scope + + #maintain key order - caller unpacks using lassign + set returnline {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} + set return_template {return [tcl::dict::create -assigned $leveldata -action $action -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + #set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs $rhs -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_not_a_list {return [dict create -assigned $leveldata -action ?mismatch-not-a-list -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_list_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_list_index_out_of_range_empty {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range-empty -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_not_a_dict {return [dict create -assigned $leveldata -action ?mismatch-not-a-dict -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + #dict 'index' when using stateful @@ etc to iterate over dict instead of by key + set tpl_return_mismatch_dict_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-dict-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_dict_key_not_found {return [dict create -assigned $leveldata -action ?mismatch-dict-key-not-found -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + + + if {![string length $selector]} { + #just return $leveldata + set script { + dict create -assigned $leveldata -action ?match -lhs "" -rhs $leveldata + } + return $script + } + + if {[string is digit -strict [join $subindices ""]]} { + #review tip 551 (tcl9+?) + #puts stderr ">>>>>>>>>>>>>>>> data: $leveldata selector: $selector subindices: $subindices" + #pure numeric keylist - put straight to lindex + # + #NOTE: this direct access e.g v/0/1/2 doesn't check out of bounds which is at odds with list access containing @ + #We will leave this as a syntax for different (more performant) behaviour + #- it's potentially a little confusing - but it would be a shame not to have the possibility to take advantage of the lindex deep indexing capability in pattern matching. + #TODO - review and/or document + # + #Todo - add a handler for v/n/n/n/n/# to allow unchecked counting at depth too. + #(or more generally - loop until we hit another type of subindex) + + #set assigned [lindex $leveldata {*}$subindices] + if {[llength $subindices] == 1} { + append script \n "# index_operation listindex" \n + lappend INDEX_OPERATIONS listindex + } else { + append script \n "# index_operation listindex-nested" \n + lappend INDEX_OPERATIONS listindex-nested + } + append script \n [tstr -return string -allowcommands { + if {[catch {lindex $leveldata ${$subindices}} leveldata]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + # -- --- --- + #append script \n $returnline \n + append script [tstr -return string $return_template] + return $script + # -- --- --- + } + if {[string match @@* $selector]} { + #part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc + set rawkeylist [split $selector /] ;#first key retains @@ - may be just '@@' + set keypath [string range $selector 2 end] + set keylist [split $keypath /] + lappend INDEX_OPERATIONS dict_path + if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1) && ([lsearch $keylist %*] == -1)} { + #pure keylist for dict - process in one go + #dict exists will return 0 if not a valid dict. + # is equivalent to {*}keylist when substituted + append script \n [tstr -return string -allowcommands { + if {[dict exists $leveldata ${$keylist}]} { + set leveldata [dict get $leveldata ${$keylist}] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + append script [tstr -return string $return_template] + return $script + # -- --- --- + } + #else + #compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access) + #process level by level + } + + + + set i_keyindex 0 + append script \n {set i_keyindex 0} + #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? + foreach index $subindices { + #set index_operation "unspecified" + set level_script_complete 0 ;#instead of break - as we can't use data to determine break when building script + set SUBPATH [join [lrange $subindices 0 $i_keyindex] /] + append script \n "# ------- START index:$index subpath:$SUBPATH ------" + set lhs $index + append script \n "set lhs $index" + + set assigned "" + append script \n {set assigned ""} + + #got_not shouldn't need to be in script + set get_not 0 + if {[tcl::string::index $index 0] eq "!"} { + append script \n {#get_not is true e.g !0-end-1 !end-4-end-2 !0 !@0 !@@key} + set index [tcl::string::range $index 1 end] + set get_not 1 + } + + # do_bounds_check shouldn't need to be in script + set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. + #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. + #append script \n {set do_boundscheck 0} + switch -exact -- $index { + # - @# { + #list length + set active_key_type "list" + if {$get_not} { + lappend INDEX_OPERATIONS not-list + append script \n {# set active_key_type "list" index_operation: not-list} + append script \n { + if {[catch {llength $leveldata}]} { + #not a list - not-length is true + set assigned 1 + } else { + #is a list - not-length is false + set assigned 0 + } + } + } else { + lappend INDEX_OPERATIONS list-length + append script \n {# set active_key_type "list" index_operation: list-length} + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} assigned]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + } + set level_script_complete 1 + } + ## { + #dict size + set active_key_type "dict" + if {$get_not} { + lappend INDEX_OPERATIONS not-dict + append script \n {# set active_key_type "dict" index_operation: not-dict} + append script \n { + if {[catch {dict size $leveldata}]} { + set assigned 1 ;#not a dict - not-size is true + } else { + set assigned 0 ;#is a dict - not-size is false + } + } + } else { + lappend INDEX_OPERATIONS dict-size + append script \n {# set active_key_type "dict" index_operation: dict-size} + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} assigned]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + } + set level_script_complete 1 + } + %# { + set active_key_type "string" + if $get_not { + error "!%# not string length is not supported" + } + #string length - REVIEW - + lappend INDEX_OPERATIONS string-length + append script \n {# set active_key_type "" index_operation: string-length} + append script \n {set assigned [string length $leveldata]} + set level_script_complete 1 + } + %%# { + #experimental + set active_key_type "string" + if $get_not { + error "!%%# not string length is not supported" + } + #string length - REVIEW - + lappend INDEX_OPERATIONS ansistring-length + append script \n {# set active_key_type "" index_operation: ansistring-length} + append script \n {set assigned [ansistring length $leveldata]} + set level_script_complete 1 + } + %str { + set active_key_type "string" + if $get_not { + error "!%str - not string-get is not supported" + } + lappend INDEX_OPERATIONS string-get + append script \n {# set active_key_type "" index_operation: string-get} + append script \n {set assigned $leveldata} + set level_script_complete 1 + } + %sp { + #experimental + set active_key_type "string" + if $get_not { + error "!%sp - not string-space is not supported" + } + lappend INDEX_OPERATIONS string-space + append script \n {# set active_key_type "" index_operation: string-space} + append script \n {set assigned " "} + set level_script_complete 1 + } + %empty { + #experimental + set active_key_type "string" + if $get_not { + error "!%empty - not string-empty is not supported" + } + lappend INDEX_OPERATIONS string-empty + append script \n {# set active_key_type "" index_operation: string-empty} + append script \n {set assigned ""} + set level_script_complete 1 + } + @words { + set active_key_type "string" + if $get_not { + error "!%words - not list-words-from-string is not supported" + } + lappend INDEX_OPERATIONS list-words-from-string + append script \n {# set active_key_type "" index_operation: list-words-from-string} + append script \n {set assigned [regexp -inline -all {\S+} $leveldata]} + set level_script_complete 1 + } + @chars { + #experimental - leading character based on result not input(?) + #input type is string - but output is list + set active_key_type "list" + if $get_not { + error "!%chars - not list-chars-from-string is not supported" + } + lappend INDEX_OPERATIONS list-from_chars + append script \n {# set active_key_type "" index_operation: list-chars-from-string} + append script \n {set assigned [split $leveldata ""]} + set level_script_complete 1 + } + @join { + #experimental - flatten one level of list + #join without arg - output is list + set active_key_type "string" + if $get_not { + error "!@join - not list-join-list is not supported" + } + lappend INDEX_OPERATIONS list-join-list + append script \n {# set active_key_type "" index_operation: list-join-list} + append script \n {set assigned [join $leveldata]} + set level_script_complete 1 + } + %join { + #experimental + #input type is list - but output is string + set active_key_type "string" + if $get_not { + error "!%join - not string-join-list is not supported" + } + lappend INDEX_OPERATIONS string-join-list + append script \n {# set active_key_type "" index_operation: string-join-list} + append script \n {set assigned [join $leveldata ""]} + set level_script_complete 1 + } + %ansiview { + set active_key_type "string" + if $get_not { + error "!%# not string-ansiview is not supported" + } + lappend INDEX_OPERATIONS string-ansiview + append script \n {# set active_key_type "" index_operation: string-ansiview} + append script \n {set assigned [ansistring VIEW $leveldata]} + set level_script_complete 1 + } + %ansiviewstyle { + set active_key_type "string" + if $get_not { + error "!%# not string-ansiviewstyle is not supported" + } + lappend INDEX_OPERATIONS string-ansiviewstyle + append script \n {# set active_key_type "" index_operation: string-ansiviewstyle} + append script \n {set assigned [ansistring VIEWSTYLE $leveldata]} + set level_script_complete 1 + } + @ { + #as this is a stateful list next index operation - we use not (!@) to mean there is no element at the next index (instead of returning the complement ie all elements except next) + #This is in contrast to other not operations on indices e.g /!2 which returns all elements except that at index 2 + + + #append script \n {puts stderr [uplevel 1 [list info vars]]} + + #NOTE: + #v_list_idx in context of _multi_bind_result + #we call destructure_func from _mult_bind_result which in turn calls the proc (or the script on first run) + append script \n {upvar 2 v_list_idx v_list_idx} + + set active_key_type "list" + append script \n {# set active_key_type "list" index_operation: list-get-next} + #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey + #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 + #while x@,y@.= is reasonably handy - especially for args e.g $len} { + set assigned 1 + } else { + set assigned 0 + } + }] + + } else { + lappend INDEX_OPERATIONS get-next + append script \n [tstr -return string -allowcommands { + set index [expr {[incr v_list_idx(@)]-1}] + + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$index+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + set assigned [lindex $leveldata $index] + } + }] + } + set level_script_complete 1 + } + @* { + set active_key_type "list" + if {$get_not} { + lappend INDEX_OPERATIONS list-is-empty + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + set assigned 1 ;#list is empty + } else { + set assigned 0 + } + }] + } else { + lappend INDEX_OPERATIONS list-get-all + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + set assigned [lrange $leveldata 0 end] + } + }] + } + set level_script_complete 1 + } + @@ { + #stateful: tracking of index using v_dict_idx + set active_key_type "dict" + lappend INDEX_OPERATIONS get-next-value + append script \n {# set active_key_type "dict" index_operation: get-next-value} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + + #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc + #x@@ = a {x y} + #x@@/@0 = a + #x@@/@1 = x y + #x@@/a = a {x y} + # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. + # (note that @@ @?@ @??@ form different subpaths - so the ? & ?? versions can be used to test match prior to @@ without affecting the index) + #review - might be more useful if they shared an index ? + # It is analogous to v1@,v2@ for lists. + # @pairs is more useful for repeated operations + + + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [list $k [dict get $leveldata $k]] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_index_out_of_range]} + } + }] + + set assignment_script [tstr -ret string -allowcommands $assignment_script] + + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @?@ { + #stateful: tracking of index using v_dict_idx + set active_key_type "dict" + lappend INDEX_OPERATIONS get?-next-value + append script \n {# set active_key_type "dict" index_operation: get?-next-value} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [dict get $leveldata $k] + } else { + set assigned [list] + } + }] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @??@ { + set active_key_type "dict" + lappend INDEX_OPERATIONS get?-next-pair + append script \n {# set active_key_type "dict" index_operation: get?-next-pair} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [list $k [dict get $leveldata $k]] + } else { + set assigned [list] + } + }] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @vv@ - @VV@ - @kk@ - @KK@ { + error "unsupported index $index" + } + default { + + #assert rules for values within @@ + #glob search is done only if there is at least one * within @@ + #if there is at least one ? within @@ - then a non match will not raise an error (quiet) + + #single or no char between @@: + #lookup/search is based on key - return is values + + #double char within @@: + #anything with a dot returns k v pairs e.g @k.@ @v.@ @..@ + #anything that is a duplicate returns k v pairs e.g @kk@ @vv@ @**@ + #anything with a letter and a star returns the type of the letter, and the search is based on the position of the star where posn 1 is for key, posn 2 is for value + #e.g @k*@ returns keys - search on values + #e.g @*k@ returns keys - search on keys + #e.g @v*@ returns values - search on values + #e.g @*v@ returns values - search on keys + + switch -glob -- $index { + @@* { + #exact key match - return value + #noisy get value - complain if key non-existent + #doesn't complain if not a dict - because we use 'tcl::dict::exists' which will return false without error even if the value isn't dict-shaped + set active_key_type "dict" + set key [string range $index 2 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey-get-value-not + #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here + #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey-get-value-not + if {[dict exists $leveldata ${$key}]} { + set assigned [dict values [dict remove $leveldata ${$key}]] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactkey-get-value + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactkey-get-value" + if {[dict exists $leveldata ${$key}]} { + set assigned [dict get $leveldata ${$key}] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + } + {@\?@*} { + #exact key match - quiet get value + #silent empty result if non-existent key - silence when non-existent key also if using not-@?@badkey which will just return whole dict + #note - dict remove will raise error on non-dict-shaped value whilst dict exists will not + set active_key_type "dict" + set key [string range $index 3 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey?-get-value-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey?-get-value-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set assigned [dict values [dict remove $leveldata ${$key}]] + }] + + } else { + lappend INDEX_OPERATIONS exactkey?-get-value + #dict exists test is safe - no need for catch + append script \n [string map [list $key] { + # set active_key_type "dict" index_operation: exactkey?-get-value + if {[dict exists $leveldata ]} { + set assigned [dict get $leveldata ] + } else { + set assigned [dict create] + } + }] + } + set level_script_complete 1 + } + {@\?\?@*} { + #quiet get pairs + #this is silent too.. so how do we do a checked return of dict key+val? + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey?-get-pair-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey?-get-pair-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set assigned [dict remove $leveldata ${$key}] + }] + } else { + lappend INDEX_OPERATIONS exactkey?-get-pair + append script \n [string map [list $key] { + # set active_key_type "dict" index_operation: exactkey?-get-pair + if {[dict exists $leveldata ]} { + set assigned [dict create [dict get $leveldata ]] + } else { + set assigned [dict create] + } + }] + } + set level_script_complete 1 + } + @..@* - @kk@* - @KK@* { + #noisy get pairs by key + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey-get-pairs-not + #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here + #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey-get-pairs-not + if {[dict exists $leveldata ${$key}]} { + set assigned [tcl::dict::remove $leveldata ${$key}] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactkey-get-pairs + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactkey-get-pairs" + if {[dict exists $leveldata ${$key}]} { + tcl::dict::set assigned ${$key} [tcl::dict::get $leveldata ${$key}] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + + } + @vv@* - @VV@* { + #noisy(?) get pairs by exact value + #return mismatch on non-match even when not- specified + set active_key_type "dict" + set keyglob [string range $index 4 end] + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + #review - for consistency we are reporting a mismatch when the antikey being looked up doesn't exist + #The utility of this is debatable + lappend INDEX_OPERATIONS exactvalue-get-pairs-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactvalue-get-pairs-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set nonmatches [dict create] + tcl::dict::for {k v} $leveldata { + if {![string equal ${$key} $v]} { + dict set nonmatches $k $v + } + } + + if {[dict size $nonmatches] < [dict size $leveldata]} { + #our key matched something + set assigned $nonmatches + } else { + #our key didn't match anything - don't return the nonmatches + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + + } else { + lappend INDEX_OPERATIONS exactvalue-get-pairs + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactvalue-get-pairs-not" + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set matches [list] + tcl::dict::for {k v} $leveldata { + if {[string equal ${$key} $v]} { + lappend matches $k $v + } + } + if {[llength $matches]} { + set assigned $matches + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + + } + {@\*@*} - {@\*v@*} - {@\*V@*} { + #dict key glob - return values only + set active_key_type "dict" + if {[string match {@\*@*} $index]} { + set keyglob [string range $index 3 end] + } else { + #vV + set keyglob [string range $index 4 end] + } + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-values-not + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + # set active_key_type "dict" index_operation: globkey-get-values-not + set matched [dict keys $leveldata ${$keyglob}] + set assigned [dict values [dict remove $leveldata {*}$matched]] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-values + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: globkey-get-values + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set matched [dict keys $leveldata ${$keyglob}] + set assigned [list] + foreach m $matched { + lappend assigned [dict get $leveldata $m] + } + }] + } + set level_script_complete 1 + + } + {@\*.@*} { + #dict key glob - return pairs + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-pairs-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-pairs-not + set matched [dict keys $leveldata ] + set assigned [dict remove $leveldata {*}$matched] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-pairs + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operations: globkey-get-pairs + set matched [dict keys $leveldata ] + set assigned [dict create] + foreach m $matched { + dict set assigned $m [dict get $leveldata $m] + } + }] + } + set level_script_complete 1 + } + {@\*k@*} - {@\*K@*} { + #dict key glob - return keys + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-keys-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-keys-not + set matched [dict keys $leveldata ] + set assigned [dict keys [dict remove $leveldata {*}$matched]] + }] + + } else { + lappend INDEX_OPERATIONS globkey-get-keys + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-keys + set assigned [dict keys $leveldata ] + }] + } + set level_script_complete 1 + } + {@k\*@*} - {@K\*@*} { + #dict value glob - return keys + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-keys-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globvalue-get-keys-not + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {![string match "" $v]} { + lappend assigned $k + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-keys + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globvalue-get-keys + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {[string match "" $v]} { + lappend assigned $k + } + } + }] + } + set level_script_complete 1 + } + {@.\*@*} { + #dict value glob - return pairs + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-pairs-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globvalue-get-pairs-not + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {![string match $v]} { + dict set assigned $k $v + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-pairs + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globvalue-get-pairs + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {[string match $v]} { + dict set assigned $k $v + } + } + }] + } + set level_script_complete 1 + } + {@V\*@*} - {@v\*@*} { + #dict value glob - return values + set active_key_type dict + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-values-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" ;# index_operation: globvalue-get-values-not + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {![string match $v]} { + lappend assigned $v + } + } + }] + + } else { + lappend INDEX_OPERATIONS globvalue-get-values + append script \n [string map [list $keyglob] { + # set active_key_type "dict" ;#index_operation: globvalue-get-value + set assigned [dict values $leveldata ] + }] + } + set level_script_complete 1 + + } + {@\*\*@*} { + #dict val/key glob return pairs) + set active_key_type "dict" + set keyvalglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkeyvalue-get-pairs-not + error "globkeyvalue-get-pairs-not todo" + } else { + lappend INDEX_OPERATIONS globkeyvalue-get-pairs + append script \n [string map [list $keyvalglob] { + # set active_key_type "dict" ;# index_operation: globkeyvalue-get-pairs-not + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {[string match $k] || [string match $v]} { + dict set assigned $k $v + } + } + }] + } + + error "globkeyvalue-get-pairs todo" + } + @* { + set active_key_type "list" + set do_bounds_check 1 + + set index [string trimleft $index @] + append script \n [string map [list $index] { + # set active_key_type "list" index_operation: ? + set index + }] + } + %* { + set active_key_type "string" + set do_bounds_check 0 + set index [string range $index 1 end] + append script \n [string map [list $index] { + # set active_key_type "string" index_operation: ? + set index + }] + } + default { + puts "destructure_func_build_body unmatched index $index" + } + } + } + } + + if {!$level_script_complete} { + + + #keyword 'pipesyntax' at beginning of error message + set listmsg "pipesyntax Unable to interpret subindex $index\n" + append listmsg "selector: '$selector'\n" + append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" + append listmsg "Additional accepted keywords include: head tail\n" + append listmsg "Use var@@key to treat value as a dict and retrieve element at key" + + #append script \n [string map [list $listmsg] {set listmsg ""}] + + + + #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against + #need to set a corresponding action + if {$active_key_type in [list "" "list"]} { + set active_key_type "list" + append script \n {# set active_key_type "list"} + #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) + switch -exact -- $index { + 0 { + if {$get_not} { + append script \n "# index_operation listindex-int-not" \n + lappend INDEX_OPERATIONS listindex-zero-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + lappend INDEX_OPERATIONS listindex-zero + set assignment_script {set assigned [lindex $leveldata 0]} + if {$do_bounds_check} { + append script \n "# index_operation listindex-int (bounds checked)" \n + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {[llength $leveldata] == 0} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } else { + append script \n "# index_operation listindex-int" \n + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + } + } + head { + #NOTE: /@head and /head both do bounds check. This is intentional + if {$get_not} { + append script \n "# index_operation listindex-head-not" \n + lappend INDEX_OPERATIONS listindex-head-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + append script \n "# index_operation listindex-head" \n + lappend INDEX_OPERATIONS listindex-head + set assignment_script {set assigned [lindex $leveldata 0]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range-empty + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax + ${$assignment_script} + } + }] + } + end { + if {$get_not} { + append script \n "# index_operation listindex-end-not" \n + lappend INDEX_OPERATIONS listindex-end-not + #on single element list Tcl's lrange will do what we want here and return nothing + set assignment_script {set assigned [lrange $leveldata 0 end-1]} + } else { + append script \n "# index_operation listindex-end" \n + lappend INDEX_OPERATIONS listindex-end + set assignment_script {set assigned [lindex $leveldata end]} + } + if {$do_bounds_check} { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + } + tail { + #NOTE: /@tail and /tail both do bounds check. This is intentional. + # + #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list + #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. + #In this way tail is different to @1-end + if {$get_not} { + append script \n "# index_operation listindex-tail-not" \n + lappend INDEX_OPERATIONS listindex-tail-not + set assignment_script {set assigned [lindex $leveldata 0]} + } else { + append script \n "# index_operation listindex-tail" \n + lappend INDEX_OPERATIONS listindex-tail + set assignment_script {set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } + anyhead { + #allow returning of head or nothing if empty list + if {$get_not} { + append script \n "# index_operation listindex-anyhead-not" \n + lappend INDEX_OPERATIONS listindex-anyhead-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + append script \n "# index_operation listindex-anyhead" \n + lappend INDEX_OPERATIONS listindex-anyhead + set assignment_script {set assigned [lindex $leveldata 0]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + anytail { + #allow returning of tail or nothing if empty list + #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. + if {$get_not} { + append script \n "# index_operation listindex-anytail-not" \n + lappend INDEX_OPERATIONS listindex-anytail-not + set assignment_script {set assigned [lindex $leveldata 0]} + } else { + append script \n "# index_operation listindex-anytail" \n + lappend INDEX_OPERATIONS listindex-anytail + set assignment_script {set assigned [lrange $leveldata 1 end]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + init { + #all but last element - same as haskell 'init' + #counterintuitively, get-notinit can therefore return first element if it is a single element list + #does bounds_check for get-not@init make sense here? maybe - review + if {$get_not} { + append script \n "# index_operation listindex-init-not" \n + lappend INDEX_OPERATIONS listindex-init-not + set assignment_script {set assigned [lindex $leveldata end]} + } else { + append script \n "# index_operation listindex-init" \n + lappend INDEX_OPERATIONS listindex-init + set assignment_script {set assigned [lrange $leveldata 0 end-1]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + list { + #get_not? + #allow returning of entire list even if empty + if {$get_not} { + lappend INDEX_OPERATIONS list-getall-not + set assignment_script {set assigned {}} + } else { + lappend INDEX_OPERATIONS list-getall + set assignment_script {set assigned $leveldata} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + raw { + #get_not - return nothing?? + #no list checking.. + if {$get_not} { + lappend INDEX_OPERATIONS getraw-not + append script \n {set assigned {}} + } else { + lappend INDEX_OPERATIONS getraw + append script \n {set assigned $leveldata} + } + } + keys { + #@get_not?? + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {$get_not} { + lappend INDEX_OPERATIONS list-getkeys-not + set assignment_script {set assigned [dict values $leveldata]} ;#not-keys is equivalent to values + } else { + lappend INDEX_OPERATIONS list-getkeys + set assignment_script {set assigned [dict keys $leveldata]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + ${$assignment_script} + } + }] + } + values { + #get_not ?? + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {$get_not} { + lappend INDEX_OPERATIONS list-getvalues-not + set assignment_script {set assigned [dict keys $leveldata]} ;#not-values is equivalent to keys + } else { + lappend INDEX_OPERATIONS list-getvalues + set assignment_script {set assigned [dict values $leveldata]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + ${$assignment_script} + } + }] + } + pairs { + #get_not ?? + if {$get_not} { + #review - return empty list instead like not-list and not-raw? + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector not-pairs_not_supported] + } else { + lappend INDEX_OPERATIONS list-getpairs + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set pairs [list] + tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} + set assigned [lindex [list $pairs [unset pairs]] 0] + } + }] + } + default { + if {[regexp {[?*]} $index]} { + if {$get_not} { + lappend INDEX_OPERATIONS listsearch-not + set assign_script [string map [list $index] { + set assigned [lsearch -all -inline -not $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listsearch + set assign_script [string map [list $index] { + set assigned [lsearch -all -inline $leveldata ] + }] + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } elseif {[string is integer -strict $index]} { + if {$get_not} { + lappend INDEX_OPERATIONS listindex-not + set assign_script [string map [list $index] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listindex + set assign_script [string map [list $index] {set assigned [lindex $leveldata ]}] + } + + if {$do_bounds_check} { + if {$index < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector index_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + set max [expr {$index + 1}] + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + # bounds_check due to @ directly specified in original index section + if {${$max} > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + ${$assign_script} + } + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + } elseif {[string first "end" $index] >=0} { + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + + if {$get_not} { + lappend INDEX_OPERATIONS listindex-endoffset-not + set assign_script [string map [list $index] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listindex-endoffset + set assign_script [string map [list $index ] {set assigned [lindex $leveldata ]}] + } + + if {$do_bounds_check} { + #tstr won't add braces - so the ${$endspec} value inserted in the expr will remain unbraced as required in this case. + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + } else { + #bounds-check is true + #leave the - from the end- as part of the offset + set offset [expr ${$endspec}] ;#don't brace! + if {($offset > 0 || abs($offset) >= $len)} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + ${$assign_script} + } + } + }] + } else { + append script \n [tstr -ret string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + if {$get_not} { + lappend INDEX_OPERATIONS list-range-not + set assign_script [string map [list $start $end ] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS list-range + set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + } + + append script \n [tstr -ret string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + + if {$do_bounds_check} { + if {[string is integer -strict $start]} { + if {$start < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector start_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set start ${$start} + if {$start+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } elseif {$start eq "end"} { + #noop + } else { + set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [expr $startoffset] ;#don't brace! + if {$startoffset > 0} { + #e.g end+1 + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + + } + append script \n [tstr -return string -allowcommands { + set startoffset ${$startoffset} + if {abs($startoffset) >= $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + if {[string is integer -strict $end]} { + if {$end < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set end ${$end} + if {$end+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } elseif {$end eq "end"} { + #noop + } else { + set endoffset [string range $end 3 end] ;#include the - from end- + + set endoffset [expr $endoffset] ;#don't brace! + if {$endoffset > 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set endoffset ${$endoffset} + if {abs($endoffset) >= $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + } + + append script \n [string map [list $assign_script] { + if {![string match ?mismatch-* $action]} { + + } + }] + + } else { + #fail now - no need for script + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } elseif {[string first - $index] > 0} { + #e.g @1-3 gets here + #JMN + if {$get_not} { + lappend INDEX_OPERATIONS list-range-not + } else { + lappend INDEX_OPERATIONS list-range + } + + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + + #handle pure int-int ranges separately + set testindex [string map [list - "" + ""] $index] + if {[string is digit -strict $testindex]} { + #don't worry about leading - negative value for indices not valid anyway + set parts [split $index -] + if {[llength $parts] != 2} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + lassign $parts start end + + #review - Tcl lrange just returns nothing silently. + #if we don't intend to implement reverse indexing - we should probably not emit an error + if {$start > $end} { + puts stderr "pipesyntax for selector $selector error - reverse index unimplemented" + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + if {$do_bounds_check} { + #append script [string map [list $start $end] { + # set start + # set end + # if {$start+1 > $len || $end+1 > $len} { + # set action ?mismatch-list-index-out-of-range + # } + #}] + #set eplusone [expr {$end+1}] + append script [tstr -return string -allowcommands { + if {$len < ${[expr {$end+1}]}} { + set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + + + if {$get_not} { + set assign_script [string map [list $start $end] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + } + + + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + + append script \n [string map [list $assign_script] { + if {![string match ?mismatch-* $action]} { + + } + }] + + } else { + #keyword 'pipesyntax' at beginning of error message + #pipesyntax error - no need to even build script - can fail now + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } + } + } elseif {$active_key_type eq "string"} { + if {[string match *-* $index]} { + lappend INDEX_OPERATIONS string-range + set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} + #todo - support more complex indices: 0-end-1 etc + + lassign [split $index -] a b + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + set assigned [string range $leveldata ${$a} ${$b}] + }] + + } else { + if {$index eq "*"} { + lappend INDEX_OPERATIONS string-all + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + set assigned $leveldata + }] + } elseif {[regexp {[?*]} $index]} { + lappend INDEX_OPERATIONS string-globmatch + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + if {[string match $index $leveldata]} { + set assigned $leveldata + } else { + set assigned "" + } + }] + } else { + lappend INDEX_OPERATIONS string-index + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + set assigned [string index $leveldata ${$index}] + }] + } + } + + } else { + #treat as dict key + if {$get_not} { + #dict remove can accept non-existent keys.. review do we require not-@?@key to get silence? + append script \n [tstr -return string { + set assigned [dict remove $leveldata ${$index}] + }] + } else { + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" + if {[dict exists $leveldata {${$index}}]} { + set assigned [dict get $leveldata {${$index}}] + } else { + set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + + } + + + } ;# end if $level_script_complete + + + append script \n { + set leveldata $assigned + } + incr i_keyindex + append script \n "# ------- END index $index ------" + } ;# end foreach + + + + #puts stdout "----> destructure rep leveldata: [rep $leveldata]" + #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" + + #maintain key order - caller unpacks using lassign + #append script \n {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} + append script \n [tstr -return string $return_template] \n + return $script + } + + #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 + } + + + + #called from match_assign/know_dot_assign for lhs of assignment - uplevel 2 to caller's level + #called from match_assign/know_dot_assign for rhs pipelined vars - uplevel 1 to write vars only in 'apply' scope + #return a dict with keys result, setvars, unsetvars + #TODO - implement cross-binding (as opposed to overwrite/reassignment) when a var appears multiple times in a pattern/multivar + #e.g x@0,x@1 will only match if value at positions 0 & 1 is the same (a form of auto-pinning?) + #e.g x,x@0 will only match a single element list + #todo blocking or - p1|p2 if p1 matches - return p1 and continue pipeline - immediately return p2 if p1 didn't match. (ie p2 not forwarded in pipeline) + # non-blocking or - p1||p2 if p1 matches - return p1 and continue pipeline - else match p2 and continue pipeline + proc _multi_bind_result {multivar data args} { + #puts stdout "---- _multi_bind_result multivar:'$multivar' data:'$data' options:'$args'" + #'ismatch' must always be first element of dict - as we dispatch on ismatch 0 or ismatch 1 + if {![string length $multivar]} { + #treat the absence of a pattern as a match to anything + #JMN2 - changed to list based destructuring + return [dict create ismatch 1 result $data setvars {} script {}] + #return [dict create ismatch 1 result [list $data] setvars {} script {}] + } + set returndict [dict create ismatch 0 result "" setvars {}] + set script "" + + set defaults [list -unset 0 -levelup 2 -mismatchinfo 1 -script 0] + set opts [dict merge $defaults $args] + set unset [dict get $opts -unset] + set lvlup [dict get $opts -levelup] + set get_mismatchinfo [dict get $opts -mismatchinfo] + + + + #first classify into var_returntype of either "pipeline" or "segment" + #segment returntype is indicated by leading % + + set varinfo [_var_classify $multivar] + set var_names [dict get $varinfo var_names] + set var_class [dict get $varinfo var_class] + set varspecs_trimmed [dict get $varinfo varspecs_trimmed] + + set var_actions [list] + set expected_values [list] + #e.g {a = abc} {b set ""} + foreach classinfo $var_class vname $var_names { + lassign [lindex $classinfo 0] v + lappend var_actions [list $v "" ""] ;#varactions keeps original lhs - not trimmed version + lappend expected_values [list var $vname spec $v info - lhs - rhs -] ;#code looks for 'info -' to see if changed from default + } + + #puts stdout "var_actions: $var_actions" + #puts stdout "expected_values: $expected_values" + + + #puts stdout "\n var_class: $var_class\n" + # e.g {{x {}} 0} {{y @0} 0} {{'ok @0} 1} {{^v @@key} 2} + + #set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [list [string range [lindex $varinfo 0 0] 1 end] [lindex $varinfo 0 1]] : [lindex $varinfo 0]}}] + #puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n" + + + #var names (possibly empty portion to the left of ) + #debug.punk.pipe.var "varnames: $var_names" 4 + + set v_list_idx(@) 0 ;#for spec with single @ only + set v_dict_idx(@@) 0 ;#for spec with @@ only + + #jn + + #member lists of returndict which will be appended to in the initial value-retrieving loop + set returndict_setvars [dict get $returndict setvars] + + set assigned_values [list] + + + #varname action value - where value is value to be set if action is set + #actions: + # "" unconfigured - assert none remain unconfigured at end + # noop no-change + # matchvar-set name is a var to be matched + # matchatom-set names is an atom to be matched + # matchglob-set + # set + # question mark versions are temporary - awaiting a check of action vs var_class + # e.g ?set may be changed to matchvar or matchatom or set + + + debug.punk.pipe.var {initial map expected_values: $expected_values} 5 + + set returnval "" + set i 0 + #assertion i incremented at each continue and at each end of loop - at end i == list length + 1 + #always use 'assigned' var in each loop + # (for consistency and to assist with returnval) + # ^var means a pinned variable - compare value of $var to rhs - don't assign + # + # In this loop we don't set variables - but assign an action entry in var_actions - all with leading question mark. + # as well as adding the data values to the var_actions list + # + # TODO! we may (commonly) encounter same vkey in the pattern - no need to reparse and re-fetch from data! + set vkeys_seen [list] + foreach v_and_key $varspecs_trimmed { + set vspec [join $v_and_key ""] + lassign $v_and_key v vkey + + set assigned "" + #The binding spec begins at first @ or # or / + + #set firstq [string first "'" $vspec] + #set v [lindex $var_names $i] + #if v contains any * and/or ? - then it is a glob match - not a varname + + lassign [destructure_func $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs + if {$matchaction eq "?match"} { + set matchaction "?set" + } + lset var_actions $i 1 $matchaction + lset var_actions $i 2 $assigned + + #update the setvars/unsetvars elements + if {[string length $v]} { + dict set returndict_setvars $v $assigned + } + + #JMN2 + #special case expansion for empty varspec (e.g , or ,,) + #if {$vspec eq ""} { + # lappend assigned_values {*}$assigned + #} else { + lappend assigned_values $assigned + #} + incr i + } + + #todo - fix! this isn't the actual tclvars that were set! + dict set returndict setvars $returndict_setvars + + #assigned_values is the ordered list of source elements in the data (rhs) as extracted by each position-spec + #For booleans the final val may later be normalised to 0 or 1 + + + #assertion all var_actions were set with leading question mark + #perform assignments only if matched ok + + + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) + if 0 { + debug.punk.pipe.var {VAR_CLASS: $var_class} 5 + debug.punk.pipe.var {VARACTIONS: $var_actions} 5 + debug.punk.pipe.var {VARSPECS_TRIMMED: $varspecs_trimmed} 5 + + debug.punk.pipe.var {atoms: [lsearch -all -inline -index 1 $var_class 1]} 5 + debug.punk.pipe.var {pins: [lsearch -all -inline -index 1 $var_class 2]} 5 + debug.punk.pipe.var {bools: [lsearch -all -inline -index 1 $var_class 3]} 5 + debug.punk.pipe.var {ints: [lsearch -all -inline -index 1 $var_class 4]} 5 + debug.punk.pipe.var {doubles: [lsearch -all -inline -index 1 $var_class 5]} 5 + debug.punk.pipe.var {vars: [lsearch -all -inline -index 1 $var_class 6]} 5 + debug.punk.pipe.var {globs: [lsearch -all -inline -index 1 $var_class 7]} 5 + } + + set match_state [lrepeat [llength $var_names] ?] + unset -nocomplain v + unset -nocomplain nm + set mismatched [list] + set i 0 + #todo - stop at first mismatch - for pattern matching (especially pipecase - we don't want to waste time reading vars if we already have a mismatch earlier in the pattern) + foreach va $var_actions { + #val comes from -assigned + lassign $va lhsspec act val ;#lhsspec is the full value source for LHS ie the full atom/number/varspec e.g for pattern ^var@@key/@0 it is "^var" + set varname [lindex $var_names $i] + + if {[string match "?mismatch*" $act]} { + #already determined a mismatch - e.g list or dict key not present + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch lhs ? rhs $val] + break + } + + + set class_key [lindex $var_class $i 1] + lassign {0 0 0 0 0 0 0 0 0 0} isatom ispin isbool isint isdouble isvar isglob isnumeric isgreaterthan islessthan + foreach ck $class_key { + switch -- $ck { + 1 {set isatom 1} + 2 {set ispin 1} + 3 {set isbool 1} + 4 {set isint 1} + 5 {set isdouble 1} + 6 {set isvar 1} + 7 {set isglob 1} + 8 {set isnumeric 1} + 9 {set isgreaterthan 1} + 10 {set islessthan 1} + } + } + + + #set isatom [expr {$class_key == 1}] + #set ispin [expr {2 in $class_key}] + #set isbool [expr {3 in $class_key}] + #set isint [expr {4 in $class_key}] + #set isdouble [expr {5 in $class_key}] + #set isvar [expr {$class_key == 6}] + #set isglob [expr {7 in $class_key}] + #set isnumeric [expr {8 in $class_key}] ;#force numeric comparison (only if # classifier present) + ##marking numbers with pin ^ has undetermined meaning. Perhaps force expr matching only? + #set isgreaterthan [expr {9 in $class_key}] + #set islessthan [expr {10 in $class_key}] + + + + if {$isatom} { + #puts stdout "==>isatom $lhsspec" + set lhs [string range $lhsspec 1 end] + if {[string index $lhs end] eq "'"} { + set lhs [string range $lhs 0 end-1] + } + lset var_actions $i 1 matchatom-set + if {$lhs eq $val} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match lhs $lhs rhs $val] + incr i + continue + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info strings-not-equal lhs $lhs rhs $val] + break + } + } + + + + + # - should set expected_values in each branch where match_state is not set to 1 + # - setting expected_values when match_state is set to 0 is ok except for performance + + + #todo - pinned booleans? we would need to disambiguate from a direct value match.. ie double tag as something like: ^&var or + #ispin may reclassify as isint,isdouble based on contained value (as they don't have their own classifier char and are unambiguous and require special handling) + if {$ispin} { + #puts stdout "==>ispin $lhsspec" + if {$act in [list "?set" "?matchvar-set"]} { + lset var_actions $i 1 matchvar-set + #attempt to read + upvar $lvlup $varname the_var + #if {![catch {uplevel $lvlup [list ::set $varname]} existingval]} {} + if {![catch {set the_var} existingval]} { + + if {$isbool} { + #isbool due to 2nd classifier i.e ^& + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-bool lhs $existingval rhs $val] + #normalise to LHS! + lset assigned_values $i $existingval + } elseif {$isglob} { + #isglob due to 2nd classifier ^* + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-glob lhs $existingval rhs $val] + } elseif {$isnumeric} { + #flagged as numeric by user using ^# classifiers + set testexistingval [join [scan $existingval %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) + if {[string is integer -strict $testexistingval]} { + set isint 1 + lset assigned_values $i $existingval + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-int lhs $existingval rhs $val] + } elseif {[string is double $existingval] || [string is double -strict $testexistingval]} { + #test existingval in case something like .5 (which scan will have missed - producing empty testexistingval) + set isdouble 1 + #doubles comparisons use float_almost_equal - so lhs can differ from rhs - for pins we always want to return the normalised lhs ie exactly what is in the var + lset assigned_values $i $existingval + + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-double lhs $existingval rhs $val] + } else { + #user's variable doesn't seem to have a numeric value + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-lhs-not-numeric lhs $existingval rhs $val] + break + } + + } else { + #standard pin - single classifier ^var + lset match_state $i [expr {$existingval eq $val}] + if {![lindex $match_state $i]} { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "string-compare-not-equal" lhs $existingval rhs $val] + break + } else { + lset expected_values $i [list var $varname spec $lhsspec info "string-compare-equal" lhs $existingval rhs $val] + } + } + + } else { + #puts stdout "pinned var $varname result:$result vs val:$val" + #failure is *probably* because var is unset - but could be a read-only var due to read-trace or it could be nonexistant namespace + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info failread-$varname lhs ? rhs $val] + break + } + } + } + + + + if {$isint} { + #note - we can have classified (above) a value such as 08 on lhs as integer - even though expr and string is integer don't do so. + #expected_values $i [list var $varname spec $lhsspec info match-lhs-int lhs $existingval rhs $val] + + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal integer in the pattern + } + if {$isgreaterthan || $islessthan} { + set lhs [string range $lhsspec 0 end-1] + set testlhs $lhs + } + if {[string index $lhs 0] eq "."} { + set testlhs $lhs + } else { + set testlhs [join [scan $lhs %lld%s] ""] + } + if {[string index $val 0] eq "."} { + set testval $val + } else { + set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros) and bignums (not leading .) + } + if {[string is integer -strict $testval]} { + if {$isgreaterthan} { + #puts "lhsspec: $lhsspec testlhs: $testlhs testval: $testval" + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-int" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-int" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-int" lhs $lhs rhs $val] + break + } + } + } elseif {[string is double -strict $testval]} { + #dragons. (and shimmering) + if {[string first "e" $val] != -1} { + #scientific notation - let expr compare + if {$isgreaterhthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-sci" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-sci" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-sci" lhs $lhs rhs $val] + break + } + } + } elseif {[string is digit -strict [string trim $val -]] } { + #probably a wideint or bignum with no decimal point + #It seems odd that bignums which just look like large integers should ever compare equal if you do a +1 to one side . + #if we use float_almost_equal they may compare equal. on the other hand expr also does apparently inconsistent thins with comparing integer-like bignums vs similar sized nums with .x at the end. + #2 values further apart can compare equal while int-like ones closer together can compare different. + #The rule seems to be for bignums that if it *looks* like a whole int the comparison is exact - but otherwise the float behaviours kick in. + #This is basically what we're doing here but with an arguably better (for some purposes!) float comparison. + #string comparison can presumably always be used as an alternative. + # + #let expr compare + if {$isgreaterthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-puredigits" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-puredigits" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-puredigits" lhs $lhs rhs $val] + break + } + } + } else { + if {[punk::float_almost_equal $testlhs $testval]} { + lset match_state $i 1 + } else { + if {$isgreaterthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-float" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-float" lhs $lhs rhs $val] + break + } + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val] + break + } + } + } + } else { + #e.g rhs not a number.. + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-unknown-rhstestval-$testval" lhs $lhs rhs $val] + break + } + } + } elseif {$isdouble} { + #dragons (and shimmering) + # + # + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal integer in the pattern + } + if {$isgreaterthan || $islessthan} { + error "+/- not yet supported for lhs float" + set lhs [string range $lhsspec 0 end-1] + set testlhs $lhs + } + if {[string index $val 0] eq "."} { + set testval $val ;#not something with some number of leading zeros + } else { + set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) + } + #expr handles leading 08.1 0009.1 etc without triggering octal + #so we don't need to scan lhs + if {[string first "e" $lhs] >= 0 || [string first "e" $testval] >= 0} { + if {$lhs == $testval} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-expr-sci lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-sci lhs $lhs rhs $val] + break + } + } elseif {[string is digit -strict [string trim $lhs -]] && [string is digit -strict [string trim $val -]]} { + #both look like big whole numbers.. let expr compare using it's bignum capability + if {$lhs == $testval} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-expr-pure-digits lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-pure-digits lhs $lhs rhs $val] + break + } + } else { + #float_almost_equal will disagree with expr based on scale.. just enough to allow for example [expr 0.2 + 0.1] to equal 0.3 - whereas expr will declare a mismatch + if {[punk::float_almost_equal $lhs $testval]} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-float-almost-equal lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-float-almost-equal lhs $lhs rhs $val] + break + } + } + } elseif {$isbool} { + #Note - cross binding of booleans deliberately doesn't compare actual underlying values - only that truthiness or falsiness matches. + #e.g &x/0,&x/1,&x/2= {1 2 yes} + # all resolve to true so the cross-binding is ok. + # Also - the setting of the variable x is normalized to 1 or 0 only. (true & false would perhaps be nicer - but 1 & 0 are theoretically more efficient for later comparisons as they can have a pure int rep?.) + # todo - consider the booleanString rep. Can/should we return true & false instead and maintain efficiency w.r.t shimmering? + # + #punk::boolean_equal $a $b + set extra_match_info "" ;# possible crossbind indication + set is_literal_boolean 0 + if {$ispin} { + #for a pinned boolean - the most useful return is the value in the pinned var rather than the rhs. This is not entirely consistent .. e.g pinned numbers will return rhs !review! + #As an additional pattern can always retrieve the raw value - pinned vars returning themselves (normalisation use-case ) seems the most consistent overall, and the most useful + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs [string range $lhsspec 1 end] ;# - strip off & classifier prefix + + if {![string length $lhs]} { + #empty varname - ok + if {[string is boolean -strict $val] || [string is double -strict $val]} { + lset match_state $i 1 + lset var_actions $i 1 "return-normalised-value" + lset assigned_values $i [expr {bool($val)}] + lset expected_values $i [list var $varname spec $lhsspec info "return-boolean-rhs-normalised" lhs - rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs" lhs - rhs $val] + break + } + } elseif {$lhs in [list 0 1]} { + #0 & 1 are the only literal numbers that satisfy Tcl's 'string is boolean' test. + set is_literal_boolean 1 + } elseif {[string index $lhs 0] eq "'" && [string index $lhs end] eq "'"} { + #literal boolean (&'yes',&'false',&'1',&'0' etc) in the pattern + #we won't waste any cycles doing an extra validity test here - it will fail in the comparison below if not a string understood by Tcl to represent a boolean. + set is_literal_boolean 1 + set lhs [string range $lhs 1 end-1] ;#strip off squotes + } else { + #todo - a standard variable name checking function for consistency.. for now we'll rule out numbers here to help avoid mistakes. + set tclvar $lhs + if {[string is double $tclvar]} { + error "pipesyntax invalid variable name '$tclvar' for boolean in pattern. (subset of legal tcl vars allowed in pattern context)" "_multi_bind_result $multivar $data $args" [list pipesyntax patternvariable invalid_boolean $tclvar] + #proc _multi_bind_result {multivar data args} + } + #treat as variable - need to check cross-binding within this pattern group + set first_bound [lsearch -index 0 $var_actions $lhsspec] + if {$first_bound == $i} { + #test only rhs (val) for boolean-ness - but boolean-ness as boolean_almost_equal understands it. (e.g floats allowed) + if {[string is boolean -strict $val] || [string is double -strict $val]} { + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# should now be the value "set". We only need this on the first_bound + #review - consider what happens if boolean is leftmost pattern - underlying value vs normalised value to continue in pipeline + #Passing underlying value is inconsistent with what goes in the tclvar - so we need to update the returnval + #puts stderr "==========[lindex $assigned_values $i]" + lset var_actions $i 2 [expr {bool($val)}] ;#normalise to 1 or 0 + lset assigned_values $i [lindex $var_actions $i 2] + #puts stderr "==========[lindex $assigned_values $i]" + lset expected_values $i [list var $varname spec $lhsspec info "match-boolean-rhs-any-lhs" lhs - rhs $val] ;#retain underlying val in expected_values for diagnostics. + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs-any-lhs" lhs - rhs $val] + break + } + } else { + set expectedinfo [lindex $expected_values $first_bound] + set expected_earlier [dict get $expectedinfo rhs] + set extra_match_info "-crossbind-first" + set lhs $expected_earlier + } + } + } + + + #may have already matched above..(for variable) + if {[lindex $match_state $i] != 1} { + if {![catch {punk::boolean_almost_equal $lhs $val} ismatch]} { + if {$ismatch} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] + break + } + } else { + #we should only error from boolean_equal if passed something Tcl doesn't recognise as a boolean + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info badvalue-boolean$extra_match_info lhs $lhs rhs $val] + break + } + } + + } elseif {$isglob} { + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal glob in the pattern - no classifier prefix + } + if {[string match $lhs $val]} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info "match-glob" lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-glob" lhs $lhs rhs $val] + break + } + + } elseif {$ispin} { + #handled above.. leave case in place so we don't run else for pins + + } else { + #puts stdout "==> $lhsspec" + #NOTE - pinned var of same name is independent! + #ie ^x shouldn't look at earlier x bindings in same pattern + #unpinned non-atoms + #cross-binding. Within this multivar pattern group only (use pin ^ for binding to result from a previous pattern) + # + switch -- $varname { + "" { + #don't attempt cross-bind on empty-varname + lset match_state $i 1 + #don't change var_action $i 1 to set + lset expected_values $i [list var $varname spec $lhsspec info "match-no-lhs-var" lhs - rhs $val] + } + "_" { + #don't cross-bind on the special 'don't-care' varname + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set + lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs-dontcare-var" lhs - rhs $val] + } + default { + set first_bound [lsearch -index 0 $var_actions $varname] + #assertion first_bound >=0, we will always find something - usually self + if {$first_bound == $i} { + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set + lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs" lhs - rhs $val] + } else { + assert {$first_bound < $i} assertion_fail: _multi_bind_result condition: [list $first_bound < $i] + set expectedinfo [lindex $expected_values $first_bound] + set expected_earlier [dict get $expectedinfo rhs] + if {$expected_earlier ne $val} { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-crossbind-first" lhs $expected_earlier rhs $val] + break + } else { + lset match_state $i 1 + #don't convert ?set to set - or var setter will write for each crossbound instance. Possibly no big deal for performance - but could trigger unnecessary write traces for example + #lset var_actions $i 1 [string range $act 1 end] + lset expected_values $i [list var $varname spec $lhsspec info "match-crossbind-first" lhs $expected_earlier rhs $val] + } + } + } + } + } + + incr i + } + + #JMN2 - review + #set returnval [lindex $assigned_values 0] + if {[llength $assigned_values] == 1} { + set returnval [join $assigned_values] + } else { + set returnval $assigned_values + } + #puts stdout "----> > rep returnval: [rep $returnval]" + + + + + + #-------------------------------------------------------------------------- + #Variable assignments (set) should only occur down here, and only if we have a match + #-------------------------------------------------------------------------- + set match_count_needed [llength $var_actions] + #set match_count [expr [join $match_state +]] ;#expr must be unbraced here + set matches [lsearch -all -inline $match_state 1] ;#default value for each match_state entry is "?" + set match_count [llength $matches] + + + debug.punk.pipe.var {MATCH_STATE: $match_state count_needed: $match_count_needed vs match_count: $match_count} 4 + debug.punk.pipe.var {VARACTIONS2: $var_actions} 5 + debug.punk.pipe.var {EXPECTED : $expected_values} 4 + + #set match_count [>f . foldl 0 [>f . sum .] $match_state] ;#ok method.. but slow compared to expr with join + if {$match_count == $match_count_needed} { + #do assignments + for {set i 0} {$i < [llength $var_actions]} {incr i} { + if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { + #isvar + if {[lindex $var_actions $i 1] eq "set"} { + upvar $lvlup $varname the_var + set the_var [lindex $var_actions $i 2] + } + } + } + dict set returndict ismatch 1 + #set i 0 + #foreach va $var_actions { + # #set isvar [expr {[lindex $var_class $i 1] == 6}] + # if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { + # #isvar + # lassign $va lhsspec act val + # upvar $lvlup $varname the_var + # if {$act eq "set"} { + # set the_var $val + # } + # #if {[lindex $var_actions $i 1] eq "set"} { + # # set the_var $val + # #} + # } + # incr i + #} + } else { + #todo - some way to restrict mismatch info to simple "mismatch" and avoid overhead of verbose message + #e.g for within pipeswitch block where mismatches are expected and the reasons are less important than moving on quickly + set vidx 0 + set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}] + set var_display_names [list] + foreach v $var_names { + if {$v eq ""} { + lappend var_display_names {{}} + } else { + 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]]} ]}}] + set msg "\n" + append msg "Unmatched\n" + append msg "Cannot match right hand side to pattern $multivar\n" + append msg "vars/atoms/etc: $var_names\n" + append msg "mismatches: [join $mismatches_display { } ]\n" + set i 0 + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) + foreach mismatchinfo $mismatches { + lassign $mismatchinfo status varname + if {$status eq "mismatch"} { + # varname can be empty string + set varclass [lindex $var_class $i 1] + set val [lindex $var_actions $i 2] + set e [dict get [lindex $expected_values $i] lhs] + set type "" + if {2 in $varclass} { + append type "pinned " + } + + if {$varclass == 1} { + set type "atom" + } elseif {$varclass == 2} { + set type "pinned var" + } elseif {3 in $varclass} { + append type "boolean" + } elseif {4 in $varclass} { + append type "int" + } elseif {5 in $varclass} { + append type "double" + } elseif {$varclass == 6} { + set type "var" + } elseif {7 in $varclass} { + append type "glob" + } elseif {8 in $varclass} { + append type "numeric" + } + if {$type eq ""} { + set type "" + } + + set lhs_tag "- [dict get [lindex $expected_values $i] info]" + set mmaction [lindex $var_actions $i 1] ;#e.g ?mismatch-dict-index-out-of-range + set tag "?mismatch-" + if {[string match $tag* $mmaction]} { + set mismatch_reason [string range $mmaction [string length $tag] end] + } else { + set mismatch_reason $mmaction + } + append msg " $type: '$varname' $mismatch_reason $lhs_tag LHS: '$e' vs RHS: '$val'\n" + } + incr i + } + #error $msg + dict unset returndict result + #structured error return - used by pipeswitch/pipecase - matching on "binding mismatch*" + dict set returndict mismatch [dict create binding mismatch varnames $var_names matchinfo $mismatches display $msg data $data] + return $returndict + } + + if {![llength $var_names]} { + #var_name entries can be blank - but it will still be a list + #JMN2 + #dict set returndict result [list $data] + dict set returndict result $data + } else { + assert {$i == [llength $var_names]} assertion_fail _multi_bind_result condition {$i == [llength $var_names]} + dict set returndict result $returnval + } + return $returndict + } + + ######################################################## + # dragons. + # using an error as out-of-band way to signal mismatch is the easiest. + # It comes at some cost (2us 2023?) to trigger catches. (which is small relative to uncompiled pipeline costs in initial version - but per pattern mismatch will add up) + # The alternative of attempting to tailcall return the mismatch as data - is *hard* if not impossible to get right. + # We need to be able to match on things like {error {mismatch etc}} - without it then itself being interpreted as a mismatch! + # A proper solution may involve a callback? tailcall some_mismatch_func? + # There may be a monad-like boxing we could do.. to keep it in data e.g {internalresult match } {internalresult mismatch } and be careful to not let boxed data escape ?? + # make sure there is good test coverage before experimenting with this + proc _handle_bind_result {d} { + #set match_caller [info level 2] + #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 + if {![dict exists $d result]} { + #uplevel 1 [list error [dict get $d mismatch]] + #error [dict get $d mismatch] + return -code error -errorcode [list binding mismatch varnames [dict get $d mismatch varnames]] [dict get $d mismatch] + } else { + return [dict get $d result] + } + } + # initially promising - but the approach runs into impossible disambiguation of mismatch as data vs an actual mismatch + proc _handle_bind_result_experimental1 {d} { + #set match_caller [info level 2] + #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 + if {![dict exists $d result]} { + tailcall return [dict get $d mismatch] + } else { + return [dict get $d result] + } + } + ######################################################## + + #timings very similar. listset3 closest in performance to pipeset. review - test on different tcl versions. + #Unfortunately all these variations seem around 10x slower than 'set list {a b c}' or 'set list [list a b c]' + #there seems to be no builtin for list setting with args syntax. lappend is close but we would need to catch unset the var first. + #proc listset1 {listvarname args} { + # tailcall set $listvarname $args + #} + #interp alias {} listset2 {} apply {{vname args} {tailcall set $vname $args}} + #interp alias {} listset3 {} apply {{vname args} {upvar $vname v; set v $args}} + proc pipeset {pipevarname args} { + upvar $pipevarname the_pipe + set the_pipe $args + } + + #pipealias should capture the namespace context of the pipeline so that commands are resolved in the namespace in which the pipealias is created + proc pipealias {targetcmd args} { + set cmdcopy [punk::objclone $args] + set nscaller [uplevel 1 [list namespace current]] + tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller] + } + proc pipealias_extract {targetcmd} { + set applybody [lindex [interp alias "" $targetcmd] 1 1] + #strip off trailing " {*}$args" + return [lrange [string range $applybody 0 end-9] 0 end] + } + #although the pipealias2 'concat' alias is cleaner in that the original pipeline can be extracted using list commands - it runs much slower + proc pipealias2 {targetcmd args} { + set cmdcopy [punk::objclone $args] + set nscaller [uplevel 1 [list namespace current]] + tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller] + } + + #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 {^([^ \t\r\n=\{]*)=(.*)} + variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + #match_assign is tailcalled from unknown - uplevel 1 gets to caller level + proc match_assign {scopepattern equalsrhs args} { + #review - :: is legal in atoms! + if {[string match "*::*" $scopepattern]} { + error "match_assign scopepattern '$scopepattern' contains namespace separator '::' - invalid." + } + #puts stderr ">> match_assign '$scopepattern=$equalsrhs' $args" + set fulltail $args + set cmdns ::punk::pipecmds + set namemapping [pipecmd_namemapping $equalsrhs] + + #we deliberately don't call pipecmd_namemapping on the scopepattern even though it may contain globs. REVIEW + #(we need for example x*= to be available as is via namespace path mechanism (from punk::pipecmds namespace)) + + set pipecmd ${cmdns}::$scopepattern=$namemapping + + #pipecmd could have glob chars - test $pipecmd in the list - not just that info commands returns results. + if {$pipecmd in [info commands $pipecmd]} { + #puts "==nscaller: '[uplevel 1 [list namespace current]]'" + #uplevel 1 [list ::namespace import $pipecmd] + set existing_path [uplevel 1 [list ::namespace path]] + if {$cmdns ni $existing_path} { + uplevel 1 [list ::namespace path [concat $existing_path $cmdns]] + } + tailcall $pipecmd {*}$args + } + + + #NOTE: + #we need to ensure for case: + #= x=y + #that the second arg is treated as a raw value - never a pipeline command + + #equalsrhs is set if there is a segment-insertion-pattern *directly* after the = + #debug.punk.pipe {match_assign '$multivar' '$equalsrhs' '$fulltail'} 4 + #can match pattern on lhs with a value where pattern is a minilang that can refer to atoms (simple non-whitespace strings), numbers, or varnames (possibly pinned) as well as a trailing spec for position within the data. + + # allow x=insertionpattern to begin a pipeline e.g x= |> string tolower ? or x=1 a b c <| X to produce a X b c + # + #to assign an entire pipeline to a var - use pipeset varname instead. + + # in our script's handling of args: + #avoid use of regexp match on each element - or we will unnecessarily force string reps on lists + #same with lsearch with a string pattern - + #wouldn't matter for small lists - but we need to be able to handle large ones efficiently without unneccessary string reps + set script [string map [list $scopepattern $equalsrhs] { + #script built by punk::match_assign + if {[llength $args]} { + #scan for existence of any pipe operator (|*> or <*|) only - we don't need position + #all pipe operators must be a single element + #we don't first check llength args == 1 because for example: + # x= <| + # x= |> + #both leave x empty. To assign a pipelike value to x we would have to do: x= <| |> (equiv: set x |>) + foreach a $args { + if {![catch {llength $a} sublen]} { + #don't enforce sublen == 1. Legal to have whitespace including newlines {| x >} + if {[string match |*> $a] || [string match <*| $a]} { + tailcall punk::pipeline = "" "" {*}$args + } + } + } + if {[llength $args] == 1} { + set segmenttail [lindex $args 0] + } else { + error "pipedata = must take a single argument. Got [llength $args] args: '$args'" "match_assign $args" [list pipedata segment too_many_elements segment_type =] + } + } else { + #set segmenttail [purelist] + set segmenttail [lreplace x 0 0] + } + }] + + + + + if {[string length $equalsrhs]} { + # as we aren't in a pipleine - there is no data to insert - we proably still need to run _split_equalsrhs to verify the syntax. + # review - consider way to turn it off as optimisation for non-pipelined assignment - but generally standard Tcl set could be used for that purpose. + # We are probably only here if testing in the repl - in which case the error messages are important. + set var_index_position_list [_split_equalsrhs $equalsrhs] + #we may have an insertion-spec that inserts a literal atom e.g to wrap in "ok" + # x='ok'>0/0 data + # => {ok data} + # we won't examine for vars as there is no pipeline - ignore + # also ignore trailing * (indicator for variable data to be expanded or not - ie {*}) + # we will differentiate between / and @ in the same way that general pattern matching works. + # /x will simply call linsert without reference to length of list + # @x will check for out of bounds + # + # !TODO - sort by position lowest to highest? or just require user to order the pattern correctly? + + + + foreach v_pos $var_index_position_list { + lassign $v_pos v indexspec positionspec + #e.g =v1/1>0 A pattern predator system) + # + #todo - review + # + # + #for now - the script only needs to handle the case of a single segment pipeline (no |> <|) + + + #temp - needs_insertion + #we can safely output no script for variable insertions for now - because if there was data available, + #we would have to be in a pipeline - in which case the script above would have delegated all our operations anyway. + #tag: positionspechandler + if {([string index $v 0] eq "'" && [string index $v end] eq "'") || [string is integer -strict $v]} { + #(for now)don't allow indexspec on a literal value baked into the pipeline - it doesn't really make sense + #- unless the pipeline construction has been parameterised somehow e.g "=${something}/0" + #review + if {[string length $indexspec]} { + error "pipesyntax literal value $v - index specification not allowed (match_assign)1" "match_assign $scopepattern $equalsrhs $args" [list pipesyntax index_on_literal] + } + if {[string index $v 0] eq "'" && [string index $v end] eq "'"} { + set datasource [string range $v 1 end-1] + } elseif {[string is integer -strict $v]} { + set datasource $v + } + append script [string map [list $datasource] { + set insertion_data "" ;#atom could have whitespace + }] + + set needs_insertion 1 + } elseif {$v eq ""} { + #default variable is 'data' + set needs_insertion 0 + } else { + append script [string map [list $v] { + #uplevel? + #set insertion_data [set ] + }] + set needs_insertion 0 + } + if {$needs_insertion} { + set script2 [punk::list_insertion_script $positionspec segmenttail ] + set script2 [string map [list "\$insertion_data" ] $script2] + append script $script2 + } + + + } + + + } + + if {![string length $scopepattern]} { + append script { + return $segmenttail + } + } else { + append script [string map [list $scopepattern] { + #we still need to bind whether list is empty or not to allow any patternmatch to succeed/fail + set d [punk::_multi_bind_result {} $segmenttail] + #return [punk::_handle_bind_result $d] + #maintenance: inlined + if {![dict exists $d result]} { + #uplevel 1 [list error [dict get $d mismatch]] + #error [dict get $d mismatch] + return -code error -level 1 -errorcode [list binding mismatch] [dict get $d mismatch] + } else { + return [dict get $d result] + } + }] + } + + debug.punk.pipe.compile {match_assign creating proc $pipecmd} 2 + uplevel 1 [list ::proc $pipecmd args $script] + set existing_path [uplevel 1 [list ::namespace path]] + if {$cmdns ni $existing_path} { + uplevel 1 [list ::namespace path [concat $existing_path $cmdns]] + } + tailcall $pipecmd {*}$args + } + + #return a script for inserting data into listvar + #review - needs updating for list-return semantics of patterns? + proc list_insertion_script {keyspec listvar {data }} { + set positionspec [string trimright $keyspec "*"] + set do_expand [expr {[string index $keyspec end] eq "*"}] + if {$do_expand} { + set exp {{*}} + } else { + set exp "" + } + #NOTE: linsert and lreplace can take multiple values at tail ie expanded data + + set ptype [string index $positionspec 0] + if {$ptype in [list @ /]} { + set index [string range $positionspec 1 end] + } else { + #the / is optional (default) at first position - and we have already discarded the ">" + set ptype "/" + set index $positionspec + } + #puts stderr ">> >> $index" + set script "" + set isint [string is integer -strict $index] + if {$index eq "."} { + #do nothing - this char signifies no insertion + } elseif {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { + if {$ptype eq "@"} { + #compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) + if {$isint} { + append script [string map [list $listvar $index] { + if {( > [llength $])} { + #not a pipesyntax error + error "pipedata insertionpattern index out of bounds. index: vs len: [llength $] use /x instead of @x to avoid check (list_insertion_script)" "list_insertion_script $keyspec" [list pipedata insertionpattern index_out_f_bounds] + } + }] + } + #todo check end-x bounds? + } + if {$isint} { + append script [string map [list $listvar $index $exp $data] { + set [linsert [lindex [list $ [unset ]] 0] ] + }] + } else { + append script [string map [list $listvar $index $exp $data] { + #use inline K to make sure the list is unshared (optimize for larger lists) + set [linsert [lindex [list $ [unset ]] 0] ] + }] + + } + } elseif {[string first / $index] < 0 && [string first - $index] > 0} { + if {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + #also - range checks for @ which must go into script !!! + append script [string map [list $listvar $start $end $exp $data] { + set [lreplace [lindex [list $ [unset ]] 0] ] + }] + } else { + error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)2" "list_insertion_script $keyspec" [list pipedata insertionpattern_invalid] + } + } elseif {[string first / $index] >= 0} { + #nested insertion e.g /0/1/2 /0/1-1 + set parts [split $index /] + set last [lindex $parts end] + if {[string first - $last] >=0} { + lassign [split $last -] a b + if {![regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $last _ a b]} { + error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)3" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] + } + if {$a eq $b} { + if {!$do_expand} { + #we can do an lset + set lsetkeys [list {*}[lrange $parts 0 end-1] $a] + append script [string map [list $listvar $lsetkeys $data] { + lset + }] + } else { + #we need to lreplace the containing item + append script [string map [list $listvar [lrange $parts 0 end-1] $a $data] { + set target [lindex $ ] + lset target {*} + lset $target + }] + } + } else { + #we need to lreplace a range at the target level + append script [string map [list $listvar [lrange $parts 0 end-1] $a $b $exp $data] { + set target [lindex $ ] + set target [lreplace $target ] + lset $target + }] + } + } else { + #last element has no -, so we are inserting at the final position - not replacing + append script [string map [list $listvar [lrange $parts 0 end-1] $last $exp $data] { + set target [lindex $ ] + set target [linsert $target ] + lset $target + }] + } + + + } else { + error "pipesyntax error in segment - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)4" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] + } + return $script + } + + + + + #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 + if {$word in [info functions]} { + return true + } + } + return false + } + + #todo - option to disable these traces which provide clarifying errors (performance hit?) + proc pipeline_args_read_trace_error {args} { + error "The pipelined data doesn't appear to be a valid Tcl list\nModify input, or use \$data or another variable name instead of \$args." "pipeline_args_read_trace_error $args" [list pipedata args_unavailable_data_not_a_list] + } + + + #NOTE: the whole idea of scanning for %x% is a lot of work(performance penalty) + #consider single placeholder e.g "_" as only positional indicator - for $data only - and require braced script with $var for more complex requirements + #possibly also *_ for expanded _ ? + #This would simplify code a lot - but also quite possible to collide with user data. + #Perhaps not a big deal as unbraced segments between |> are mainly(?) a convenience for readability/repl etc. + # (but importantly (at pipeline start anyway) unbraced segments are a mechanism to inject data from calling scope or from pipeline args <|) + # + #detect and retrieve %xxx% elements from item without affecting list/string rep + #commas, @, ', ^ and whitespace not part of a valid tag (allows some substitution within varspecs) + #%% is not a valid tag + #(as opposed to using regexp matching which causes string reps) + proc get_tags {item} { + set chars [split $item {}] + set terminal_chars [list , @ ' ^ " " \t \n \r] + #note % is both terminal and initiating - so for the algorithm we don't include it in the list of terminal_chars + set nonterminal [lmap v $chars {expr {$v ni $terminal_chars}}] + set percents [lmap v $chars {expr {$v eq "%"}}] + #useful for test/debug + #puts "CHARS : $chars" + #puts "NONTERMINAL: $nonterminal" + #puts "PERCENTS : $percents" + set sequences [list] + set in_sequence 0 + set start -1 + set end -1 + set i 0 + #todo - some more functional way of zipping/comparing these lists? + set s_length 0 ;#sequence length including % symbols - minimum for tag therefore 2 + foreach n $nonterminal p $percents { + if {!$in_sequence} { + if {$n & $p} { + set s_length 1 + set in_sequence 1 + set start $i + set end $i + } else { + set s_length 0 + } + } else { + if {$n ^ $p} { + incr s_length + incr end + } else { + if {$n & $p} { + if {$s_length == 1} { + # % followed dirctly by % - false start + #start again from second % + set s_length 1 + set in_sequence 1 + set start $i + set end $i + } else { + incr end + lappend sequences [list $start $end] + set in_sequence 0 + set s_length 0 + set start -1; set end -1 + } + } else { + #terminated - not a tag + set in_sequence 0 + set s_length 0 + set start -1; set end -1 + } + } + } + incr i + } + + set tags [list] + foreach s $sequences { + lassign $s start end + set parts [lrange $chars $start $end] + lappend tags [join $parts ""] + } + return $tags + } + + #show underlying rep of list and first level + proc rep_listname {lname} { + upvar $lname l + set output "$lname list rep: [rep $l]\n" + foreach item $l { + append output "-rep $item\n" + append output " [rep $item]\n" + } + return $output + } + + # + # + # 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 ~* + #The ~ being mapped to $data in the pipeline. + #This is more readable and simpler for beginners - although it doesn't handle more advanced insertion requirements. + #possibility to mix as we can already with .= and = + #e.g + #x.= list aa b c |> ~= lmap v ~ {string length $v} |> .=>* tcl::mathfunc::max + # -- + proc pipeline {segment_op initial_returnvarspec equalsrhs args} { + set fulltail $args + #unset args ;#leave args in place for error diagnostics + debug.punk.pipe {call pipeline: op:'$segment_op' '$initial_returnvarspec' '$equalsrhs' '$fulltail'} 4 + #debug.punk.pipe.rep {[rep_listname fulltail]} 6 + + + #--------------------------------------------------------------------- + # test if we have an initial x.=y.= or x.= y.= + + #nextail is tail for possible recursion based on first argument in the segment + set nexttail [lassign $fulltail next1] ;#tail head + + switch -- $next1 { + pipematch { + set results [uplevel 1 [list pipematch {*}$nexttail]] + debug.punk.pipe {>>> pipematch results: $results} 1 + + set d [_multi_bind_result $initial_returnvarspec $results] + return [_handle_bind_result $d] + } + pipecase { + set msg "pipesyntax\n" + append msg "pipecase does not return a value directly in the normal way\n" + append msg "It will return a casemismatch dict on mismatch\n" + append msg "But on a successful match - it will use an 'error' mechanism to return {ok result {something}} in the caller's scope -\n" + append msg "This will appear as an error in the repl, or disrupt pipeline result propagation if not in an appropriate wrapper\n" + append msg "Call pipecase from within a pipeline script block or wrapper such as pipeswitch or apply." + error $msg + } + } + + #temp - this is related to a script for the entire pipeline (functional composition) - not the script for the segment-based x=y or x.=y proc. + set ::_pipescript "" + + + + #NOTE: + #important that for assignment: + #= x=y .. + #The second element is always treated as a raw value - not a pipeline instruction. + #whereas... for execution: + #.= x=y the second element is a pipeline-significant symbol based on the '=' even if it was passed in as an argument. + #Usually an execution segment (.= cmd etc..) will have args inserted at the tail anyway - + #- but if the pipeline is designed to put an argument in the zero position - then presumably it is intended as a pipeline-significant element anyway + #This gives a *slight* incompatibility with external commands containing '=' - in that they may not work properly in pipelines + # + if {$segment_op ne "="} { + #handle for example: + #var1.= var2= "etc" |> string toupper + # + #var1 will contain ETC (from entire pipeline), var2 will contain etc (from associated segment) + # + + if {([set nexteposn [string first = $next1]] >= 0) && (![arg_is_script_shaped $next1]) } { + #*SUB* pipeline recursion. + #puts "======> recurse based on next1:$next1 " + if {[string index $next1 $nexteposn-1] eq {.}} { + #var1.= var2.= ... + #non pipelined call to self - return result + set results [uplevel 1 [list $next1 {*}$nexttail]] + #debug.punk.pipe.rep {==> rep recursive results: [rep $results]} 5 + #debug.punk.pipe {>>> results: $results} 1 + return [_handle_bind_result [_multi_bind_result $initial_returnvarspec $results]] + } + #puts "======> recurse assign based on next1:$next1 " + #if {[regexp {^([^ \t\r\n=\{]*)=(.*)} $next1 _ nextreturnvarspec nextrhs]} { + #} + #non pipelined call to plain = assignment - return result + set results [uplevel 1 [list $next1 {*}$nexttail]] + #debug.punk.pipe {>>> results: $results} 1 + set d [_multi_bind_result $initial_returnvarspec $results] + return [_handle_bind_result $d] + } + } + + set procname $initial_returnvarspec.=$equalsrhs + + #--------------------------------------------------------------------- + + #todo add 'op' argument and handle both .= and = + # + #|> data piper symbol + #<| args piper symbol (arguments supplied at end of pipeline e.g from commandline or from calling and/or currying the command) + # + + set more_pipe_segments 1 ;#first loop + + #this contains the main %data% and %datalist% values going forward in the pipeline + #as well as any extra pipeline vars defined in each |> + #It also contains any 'args' with names supplied in <| + set dict_tagval [dict create] ;#cumulative %x% tag dict which operates on the whole length of the pipeline + + #determine if there are input args at the end of the pipeline indicated by reverse <| symbol possibly with argspecs e.g transform x y z =0} { + set tailremaining [lrange $fulltail 0 $firstargpipe_posn-1] + set argslist [lrange $fulltail $firstargpipe_posn+1 end] ;#Note that this could be a whole other pipeline with |> and/or <| elements. + set argpipe [lindex $fulltail $firstargpipe_posn] + set argpipespec [string range $argpipe 1 end-1] ;# strip off < & | from " b1 b2 b3 |outpipespec> c1 c2 c3 + # for a1 a2 a3 - the pipe to the right is actually an outpipespec and for c1 c2 c3 the pipe to the left is an inpipespec + + + #our initial command list always has *something* before we see any pipespec |> + #Therefore we initially have a blank inpipespec (although in effect, it comes from the argpipespec <|) + set inpipespec $argpipespec + set outpipespec "" + + #avoiding regexp on each arg to maintain list reps + #set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] + ## set tailmap [lmap v $tailremaining {if {[regexp {^\|(.*)>$} $v _ outpipespec] && !$pipeseen} {set pipeseen 1;set outpipespec} {if {$pipeseen} {set v} 0}}] + #e.g for: a b c |> e f g |> h + #set firstpipe_posn [lsearch $tailmap {| >}] + + set firstpipe_posn [lsearch $tailremaining "|*>"] + + if {$firstpipe_posn >=0} { + set outpipespec [string range [lindex $tailremaining $firstpipe_posn] 1 end-1] + set segment_members [lrange $tailremaining 0 $firstpipe_posn-1] + #set tailremaining [lrange $tailremaining $firstpipe_posn+1 end] + set tailremaining [lreplace $tailremaining 0 $firstpipe_posn] ;#generally too short for any K combinator benefit? what about lists with scripts? is it dependent on list length or also element content size? + } else { + set segment_members $tailremaining + set tailremaining [list] + } + + + + set script_like_first_word 0 + set rhs $equalsrhs + + set segment_first_is_script 0 ;#default assumption until tested + + set segment_first_word [lindex $segment_members 0] + if {$segment_op ne "="} { + if {[arg_is_script_shaped $segment_first_word]} { + set segment_first_is_script 1 + } + } else { + if {[llength $segment_members] > 1} { + error "pipedata = can only accept a single argument (got: '$segment_members')" "pipeline $segment_op $initial_returnvarspec $equalsrhs $fulltail" [list pipedata too_many_elements] + #proc pipeline {segment_op initial_returnvarspec equalsrhs args} + } + set segment_members $segment_first_word + } + + + + #tailremaining includes x=y during the loop. + set returnvarspec $initial_returnvarspec + if {![llength $argslist]} { + unset -nocomplain previous_result ;# we want it unset for first iteration - differentiate from empty string + } else { + set previous_result $argslist + } + + set segment_result_list [list] + set i 0 ;#segment id + set j 1 ;#next segment id + set pipespec(args) $argpipespec ;# from trailing <| + set pipespec(0,in) $inpipespec + set pipespec(0,out) $outpipespec + + set max_iterations 100 ;# configurable? -1 for no limit ? This is primarily here to aid debugging of runaway loops in initial development .. should probably set to no-limit in final version. + while {$more_pipe_segments == 1} { + #--------------------------------- + debug.punk.pipe {[a yellow bold]i$i SEGMENT MEMBERS([llength $segment_members]): $segment_members[a]} 4 + debug.punk.pipe {[a yellow bold]i$i TAIL REMAINING([llength $tailremaining]): $tailremaining[a]} 4 + debug.punk.pipe {[a] inpipespec(prev [a yellow bold]|$pipespec($i,in)[a]>) outpipespec(next [a+ yellow bold]|$pipespec($i,out)>[a])} 4 + debug.punk.pipe {[a cyan bold] segment_first_is_script:$segment_first_is_script} 4 + if {$segment_first_is_script} { + debug.punk.pipe {[a cyan bold] script segment: [lindex $segment_members 0][a]} 4 + } + + + + #examine inpipespec early to give faster chance for mismatch. ie before scanning segment for argument position + set segment_result "" + if {[info exists previous_result]} { + set prevr $previous_result + } else { + set prevr "" + } + set pipedvars [dict create] + if {[string length $pipespec($i,in)]} { + #check the varspecs within the input piper + # - data and/or args may have been manipulated + set d [apply {{mv res} { + punk::_multi_bind_result $mv $res -levelup 1 + }} $pipespec($i,in) $prevr] + #temp debug + #if {[dict exists $d result]} { + #set jjj [dict get $d result] + #puts "!!!!! [rep $jjj]" + #} + set inpipespec_result [_handle_bind_result $d] + set pipedvars [dict get $d setvars] + set prevr $inpipespec_result ;# leftmost spec in |> needs to affect pipeline flow of 'data' + #puts stdout "inpipespec:|$pipespec($i,in)> prevr:$prevr setvars: $pipedvars" + } + debug.punk.pipe {[a] previous_iteration_result: $prevr[a]} 6 + debug.punk.pipe.rep {rep previous_iteration_result [rep $prevr]} + + + if {$i == $max_iterations} { + puts stderr "ABORTING. Reached max_iterations $max_iterations (todo: make configurable)" + set more_pipe_segments 0 + } + + set insertion_patterns [_split_equalsrhs $rhs] ;#raises error if rhs of positionspec not like /* or @* + set segment_has_insertions [expr {[llength $insertion_patterns] > 0}] + #if {$segment_has_insertions} { + # puts stdout ">>> $segment_members insertion_patterns $insertion_patterns" + #} + + debug.punk.pipe.var {segment_has_insertions: $insertion_patterns} 5 + debug.punk.pipe.rep {[rep_listname segment_members]} 4 + + + + + #whether the segment has insertion_patterns or not - apply any modification from the piper argspecs (script will use modified args/data) + #pipedvars comes from either previous segment |>, or <| args + if {[dict exists $pipedvars "data"]} { + #dict set dict_tagval %data% [list [dict get $pipedvars "data"]] + dict set dict_tagval data [dict get $pipedvars "data"] + } else { + if {[info exists previous_result]} { + dict set dict_tagval data $prevr + } + } + foreach {vname val} $pipedvars { + #add additionally specified vars and allow overriding of %args% and %data% by not setting them here + if {$vname eq "data"} { + #already potentially overridden + continue + } + dict set dict_tagval $vname $val + } + + #todo! + #segment_script - not in use yet. + #will require non-iterative pipeline processor to use ... recursive.. or coroutine based + set script "" + + if {!$segment_has_insertions} { + #debug.punk.pipe.var {[a cyan]SEGMENT has no tags[a]} 7 + #add previous_result as data in end position by default, only if *no* insertions specified (data is just list-wrapped previous_result) + #set segment_members_filled [concat $segment_members [dict get $dict_tagval %data%]] ;# data flows through by default as single element - not args - because some strings are not valid lists + #insertion-specs with a trailing * can be used to insert data in args format + set segment_members_filled $segment_members + if {[dict exists $dict_tagval data]} { + lappend segment_members_filled [dict get $dict_tagval data] + } + + } else { + debug.punk.pipe.var {processing insertion_pattern dict_tagval: $dict_tagval} 4 + set segment_members_filled [list] + set segmenttail $segment_members ;# todo - change to segment_members here to match punk::match_assign + + set rhsmapped [pipecmd_namemapping $rhs] + set cmdname "::punk::pipecmds::insertion::_$rhsmapped" + #glob chars have been mapped - so we can test by comparing info commands result to empty string + if {[info commands $cmdname] eq ""} { + + set insertion_script "proc $cmdname {dict_tagval segmenttail} {\n" + foreach v_pos $insertion_patterns { + #puts stdout "v_pos '$v_pos'" + lassign $v_pos v indexspec positionspec ;#v may be atom, or varname (in pipeline scope) + #puts stdout "v:'$v' indexspec:'$indexspec' positionspec:'$positionspec'" + #julz + + append insertion_script \n [string map [list $v_pos] { + lassign [list ] v indexspec positionspec + }] + + if {([string index $v 0] eq "'") && ([string index $v end] eq "'")} { + set v [string range $v 1 end-1] ;#assume trailing ' is present! + if {[string length $indexspec]} { + error "pipesyntax - index not supported on atom" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] + } + append insertion_script \n "set insertion_data [list $v]" ;#sub in shortened $v now -i.e use atom value itself (string within single quotes) + } elseif {[string is double -strict $v]} { + #don't treat numbers as variables + if {[string length $indexspec]} { + error "pipesyntax - index not supported on number" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] + } + append insertion_script \n {set insertion_data $v} + } else { + #todo - we should potentially group by the variable name and pass as a single call to _multi_bind_result - because stateful @ and @@ won't work in independent calls + append insertion_script \n [string map [list $cmdname] { + #puts ">>> v: $v dict_tagval:'$dict_tagval'" + if {$v eq ""} { + set v "data" + } + if {[dict exists $dict_tagval $v]} { + set insertion_data [dict get $dict_tagval $v] + #todo - use destructure_func + set d [punk::_multi_bind_result $indexspec $insertion_data] + set insertion_data [punk::_handle_bind_result $d] + } else { + #review - skip error if varname is 'data' ? + #e.g we shouldn't really fail for: + #.=>* list a b c <| + #we need to be careful not to insert empty-list as an argument by default + error "pipevariable - varname $v not present in pipeline context. pipecontext_vars: [dict keys $dict_tagval] (2)" " pipecontext_vars: [dict keys $dict_tagval]" [list pipevariable variable_not_in_pipeline_scope] + } + + }] + } + + + + + #append script [string map [list $getv]{ + # + #}] + #maintenance - index logic should be similar identical? to to match_assign - which only needs to process atoms because it (for now?) delegates all pipeline ops here, so no vars available (single segment assign) + #tag: positionspechandler + + + #puts stdout "=== list_insertion_script '$positionspec' segmenttail " + set script2 [punk::list_insertion_script $positionspec segmenttail ] + set script2 [string map [list "\$insertion_data" ] $script2] + append insertion_script \n $script2 + + } + append insertion_script \n {set segmenttail} + append insertion_script \n "}" + #puts stderr "$insertion_script" + debug.punk.pipe.compile {creating proc ::punk::pipecmds::insertion::_$rhsmapped } 4 + eval $insertion_script + } + + set segment_members_filled [::punk::pipecmds::insertion::_$rhsmapped $dict_tagval [lindex [list $segmenttail [unset segmenttail]] 0] ] + + #set segment_members_filled $segmenttail + #note - length of segment_members_filled may now differ from length of original segment_members! (if do_expand i.e trailing * in any insertion_patterns) + + } + set rhs [string map $dict_tagval $rhs] ;#obsolete? + + debug.punk.pipe.rep {segment_members_filled rep: [rep $segment_members_filled]} 4 + + + # script index could have changed!!! todo fix! + + #we require re_dot_assign before re_assign (or fix regexes so order doesn't matter!) + if {(!$segment_first_is_script ) && $segment_op eq ".="} { + #no scriptiness detected + + #debug.punk.pipe.rep {[a yellow bold][rep_listname segment_members_filled][a]} 4 + + set cmdlist_result [uplevel 1 $segment_members_filled] + #debug.punk.pipe {[a green bold]forward_result: $forward_result[a]} 4 + #debug.punk.pipe.rep {[a yellow bold]forward_result REP: [rep $forward_result][a]} 4 + + #set d [_multi_bind_result $returnvarspec [punk::K $cmdlist_result [unset cmdlist_result]]] + set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result ]] 0]] + + set segment_result [_handle_bind_result $d] + #puts stderr ">>forward_result: $forward_result segment_result $segment_result" + + + } elseif {$segment_op eq "="} { + #slightly different semantics for assigment! + #We index into the DATA - not the position within the segment! + #(an = segment must take a single argument, as opposed to a .= segment) + #(This was a deliberate design choice for consistency with set, and to reduce errors.) + #(we could have allowed multiple args to = e.g to form a list, but it was tried, and the edge-cases were unintuitive and prone to user error) + #(The choice to restrict to single argument, but allow insertion and appending via insertion-specs is more explicit and reliable even though the insertion-specs operate differently to those of .=) + # + #we have to ensure that for an empty segment - we don't append to the empty list, thus listifying the data + #v= {a b c} |> = + # must return: {a b c} not a b c + # + if {!$segment_has_insertions} { + set segment_members_filled $segment_members + if {[dict exists $dict_tagval data]} { + if {![llength $segment_members_filled]} { + set segment_members_filled [dict get $dict_tagval data] + } else { + lappend segment_members_filled [dict get $dict_tagval data] + } + } + } + + set d [_multi_bind_result $returnvarspec [lindex [list $segment_members_filled [unset segment_members_filled ]] 0]] + set segment_result [_handle_bind_result $d] + + + } elseif {$segment_first_is_script || $segment_op eq "script"} { + #script + debug.punk.pipe {[a+ cyan bold].. evaluating as script[a]} 2 + + set script [lindex $segment_members 0] + + #build argument lists for 'apply' + set segmentargnames [list] + set segmentargvals [list] + foreach {k val} $dict_tagval { + if {$k eq "args"} { + #skip args - it is manually added at the end of the apply list if it's a valid tcl list + continue + } + lappend segmentargnames $k + lappend segmentargvals $val + } + + set argsdatalist $prevr ;#default is raw result as a list. May be overridden by an argspec within |> e.g |args@@key> or stripped if not a tcl list + #puts "------> rep prevr argsdatalist: [rep $argsdatalist]" + set add_argsdata 0 + if {[dict exists $dict_tagval "args"]} { + set argsdatalist [dict get $dict_tagval "args"] + #see if the raw result can be treated as a list + if {[catch {lindex $argsdatalist 0}]} { + #we cannot supply 'args' + set pre_script "" + #todo - only add trace if verbose warnings enabled? + append pre_script "trace add variable args read punk::pipeline_args_read_trace_error\n" + set script $pre_script + append script $segment_first_word + set add_argsdata 0 + } else { + set add_argsdata 1 + } + } + + debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4 + set ns [uplevel 1 {::namespace current}] + if {!$add_argsdata} { + debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4 + #puts stderr " script: $script" + #puts stderr " vals: $segmentargvals" + set evaluation [uplevel 1 [list ::apply [::list $segmentargnames $script $ns] {*}$segmentargvals]] + } else { + debug.punk.pipe {APPLY2: (args is set)segment vars:$segmentargnames} 4 + #puts stderr " script: $script" + #puts stderr " vals: $segmentargvals $argsdatalist" + #pipeline script context should be one below calling context - so upvar v v will work + #ns with leading colon will fail with apply + set evaluation [uplevel 1 [list ::apply [::list [::concat $segmentargnames args] $script $ns] {*}$segmentargvals {*}$argsdatalist]] + } + + debug.punk.pipe.rep {script result, evaluation: [rep_listname evaluation]} 4 + #puts "---> rep script evaluation result: [rep $evaluation]" + #set d [_multi_bind_result $returnvarspec [punk::K $evaluation [unset evaluation]]] + + #trailing segment_members are *pipedata* scripts - as opposed to ordinary pipeline scripts! + set tail_scripts [lrange $segment_members 1 end] + if {[llength $tail_scripts]} { + set r [pipedata $evaluation {*}$tail_scripts] + } else { + set r $evaluation + } + set d [_multi_bind_result $returnvarspec [lindex [list $r [unset r]] 0]] + set segment_result [_handle_bind_result $d] + } else { + #tags ? + #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 + if {false} { + #set s [list uplevel 1 [concat $rhs $segment_members_filled]] + if {![info exists pscript]} { + upvar ::_pipescript pscript + } + if {![info exists pscript]} { + #set pscript $s + set pscript [funcl::o_of_n 1 $segment_members] + } else { + #set pscript [string map [list

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

]]}] + #set snew "set pipe_$i \[uplevel 1 \[list $rhs $segment_members_filled " + #append snew "set pipe_[expr $i -1]" + #append pscript $snew + set pscript [funcl::o_of_n 1 $segment_members $pscript] + + } + } + + set cmdlist_result [uplevel 1 $segment_members_filled] + #set d [_multi_bind_result $returnvarspec [punk::K $segment_members_filled [unset segment_members_filled]]] + set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result]] 0 ]] + + #multi_bind_result needs to return a funcl for rhs of: + #lindex [list [set syncvar [main pipeline.. ]] [rhs binding funcl...] 1 ] + #which uses syncvar + # + #The lhs of 'list' runs first so now syncvar can be the root level of the rhs function list and bind the necessary vars. + #NOTE: unintuitively, we are returning the value of rhs to the main pipleline! (leftmost binding) this is because the leftmost binding determines what goes back to the pipeline result + + set segment_result [_handle_bind_result $d] + } + #the subresult doesn't need to go backwards - as the final assignment can emit the result into a variable + #It makes more sense and is ultimately more useful (and more easy to reason about) for the result of each assignment to be related only to the pre-pipe section + #It may however make a good debug point + #puts stderr "segment $i segment_result:$segment_result" + + debug.punk.pipe.rep {[rep_listname segment_result]} 3 + + + + + + #examine tailremaining. + # either x x x |?> y y y ... + # or just y y y + #we want the x side for next loop + + #set up the conditions for the next loop + #|> x=y args + # inpipespec - contents of previous piper |xxx> + # outpipespec - empty or content of subsequent piper |xxx> + # previous_result + # assignment (x=y) + + + set pipespec($j,in) $pipespec($i,out) + set outpipespec "" + set tailmap "" + set next_pipe_posn -1 + if {[llength $tailremaining]} { + + #set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] + ##e.g for: a b c |> e f g |> h + #set next_pipe_posn [lsearch $tailmap {| >}] + set next_pipe_posn [lsearch $tailremaining "|*>"] + + set outpipespec [string range [lindex $tailremaining $next_pipe_posn] 1 end-1] + } + set pipespec($j,out) $outpipespec + + + set script_like_first_word 0 + if {[llength $tailremaining] || $next_pipe_posn >= 0} { + + if {$next_pipe_posn >=0} { + set next_all_members [lrange $tailremaining 0 $next_pipe_posn-1] ;#exclude only piper |xxx> for + set tailremaining [lrange $tailremaining $next_pipe_posn+1 end] + + } else { + set next_all_members $tailremaining + set tailremaining [list] + } + + + #assignment is the arg immediately following |> operator e.g x.=blah or x=etc (or a normal commandlist or script!) + set segment_first_word "" + set returnvarspec "" ;# the lhs of x=y + set segment_op "" + set rhs "" + set segment_first_is_script 0 + if {[llength $next_all_members]} { + if {[arg_is_script_shaped [lindex $next_all_members 0]]} { + set segment_first_word [lindex $next_all_members 0] + set segment_first_is_script 1 + set segment_op "" + set segment_members $next_all_members + } else { + set possible_assignment [lindex $next_all_members 0] + #set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + if {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} $possible_assignment _ returnvarspec rhs]} { + set segment_op ".=" + set segment_first_word [lindex $next_all_members 1] + set script_like_first_word [arg_is_script_shaped $segment_first_word] + if {$script_like_first_word} { + set segment_first_is_script 1 ;#relative to segment_members which no longer includes the .= + } + set segment_members [lrange $next_all_members 1 end] + } elseif {[regexp {^([^ \t\r\n=]*)=(.*)} $possible_assignment _ returnvarspec rhs]} { + set segment_op "=" + #never scripts + #must be at most a single element after the = ! + if {[llength $next_all_members] > 2} { + #raise this as pipesyntax as opposed to pipedata? + error "pipesyntax - at most one element can follow = (got [lrange $next_all_members 1 end])" "pipeline $segment_op $returnvarspec $rhs [lrange $next_all_members 1 end]" [list pipesyntax too_many_elements] + } + set segment_first_word [lindex $next_all_members 1] + if {[catch {llength $segment_first_word}]} { + set segment_is_list 0 ;#only used for segment_op = + } else { + set segment_is_list 1 ;#only used for segment_op = + } + + set segment_members $segment_first_word + } else { + #no assignment operator and not script shaped + set segment_op "" + set returnvarspec "" + set segment_first_word [lindex $next_all_members 0] + set segment_first_word [lindex $next_all_members 1] + set segment_members $next_all_members + #puts stderr ">>3 no-operator segment_first_word: '$segment_first_word'" + } + } + + + } else { + #?? two pipes in a row ? + debug.punk.pipe {[a+ yellow bold]WARNING: no segment members found[a]} 0 + set segment_members return + set segment_first_word return + } + + #set forward_result $segment_result + #JMN2 + set previous_result $segment_result + #set previous_result [join $segment_result] + } else { + debug.punk.pipe {[a+ cyan bold]End of pipe segments ($i)[a]} 4 + #output pipe spec at tail of pipeline + + set pipedvars [dict create] + if {[string length $pipespec($i,out)]} { + set d [apply {{mv res} { + punk::_multi_bind_result $mv $res -levelup 1 + }} $pipespec($i,out) $segment_result] + set segment_result [_handle_bind_result $d] + set pipedvars [dict get $d setvars] + } + + set more_pipe_segments 0 + } + + #the segment_result is based on the leftmost var on the lhs of the .= + #whereas forward_result is always the entire output of the segment + #JMN2 + #lappend segment_result_list [join $segment_result] + lappend segment_result_list $segment_result + incr i + incr j + } ;# end while + + return [lindex $segment_result_list end] + #JMN2 + #return $segment_result_list + #return $forward_result + } + + + #just an experiment + #what advantage/difference versus [llength [lrange $data $start $end]] ??? + proc data_range_length {data start end} { + set datalen [llength $data] + + #normalize to s and e + if {$start eq "end"} { + set s [expr {$datalen - 1}] + } elseif {[string match end-* $start]} { + set stail [string range $start 4 end] + set posn [expr {$datalen - $stail -1}] + if {$posn < 0} { + return 0 + } + set s $posn + } else { + #int + if {($start < 0) || ($start > ($datalen -1))} { + return 0 + } + set s $start + } + if {$end eq "end"} { + set e [expr {$datalen - 1}] + } elseif {[string match end-* $end]} { + set etail [string range $end 4 end] + set posn [expr {$datalen - $etail -1}] + if {$posn < 0} { + return 0 + } + set e $posn + } else { + #int + if {($end < 0)} { + return 0 + } + set e $end + } + if {$s > ($datalen -1)} { + return 0 + } + if {$e > ($datalen -1)} { + set e [expr {$datalen -1}] + } + + + + if {$e < $s} { + return 0 + } + + return [expr {$e - $s + 1}] + } + + # unknown -- + # This procedure is called when a Tcl command is invoked that doesn't + # exist in the interpreter. It takes the following steps to make the + # command available: + # + # 1. See if the autoload facility can locate the command in a + # Tcl script file. If so, load it and execute it. + # 2. If the command was invoked interactively at top-level: + # (a) see if the command exists as an executable UNIX program. + # If so, "exec" the command. + # (b) see if the command requests csh-like history substitution + # in one of the common forms !!, !, or ^old^new. If + # so, emulate csh's history substitution. + # (c) see if the command is a unique abbreviation for another + # command. If so, invoke the command. + # + # Arguments: + # args - A list whose elements are the words of the original + # command, including the command name. + + #review - we shouldn't really be doing this + #We need to work out if we can live with the real default unknown and just inject some special cases at the beginning before falling-back to the normal one + + proc ::unknown args { + #puts stderr "unk>$args" + variable ::tcl::UnknownPending + global auto_noexec auto_noload env tcl_interactive errorInfo errorCode + + if {[info exists errorInfo]} { + set savedErrorInfo $errorInfo + } + if {[info exists errorCode]} { + set savedErrorCode $errorCode + } + + set name [lindex $args 0] + if {![info exists auto_noload]} { + # + # Make sure we're not trying to load the same proc twice. + # + if {[info exists UnknownPending($name)]} { + return -code error "self-referential recursion\ + in \"unknown\" for command \"$name\"" + } + set UnknownPending($name) pending + set ret [catch { + auto_load $name [uplevel 1 {::namespace current}] + } msg opts] + unset UnknownPending($name) + if {$ret != 0} { + dict append opts -errorinfo "\n (autoloading \"$name\")" + return -options $opts $msg + } + if {![array size UnknownPending]} { + unset UnknownPending + } + if {$msg} { + if {[info exists savedErrorCode]} { + set ::errorCode $savedErrorCode + } else { + unset -nocomplain ::errorCode + } + if {[info exists savedErrorInfo]} { + set errorInfo $savedErrorInfo + } else { + unset -nocomplain errorInfo + } + set code [catch {uplevel 1 $args} msg opts] + if {$code == 1} { + # + # Compute stack trace contribution from the [uplevel]. + # Note the dependence on how Tcl_AddErrorInfo, etc. + # construct the stack trace. + # + set errInfo [dict get $opts -errorinfo] + set errCode [dict get $opts -errorcode] + set cinfo $args + if {[string length [encoding convertto utf-8 $cinfo]] > 150} { + set cinfo [string range $cinfo 0 150] + while {[string length [encoding convertto utf-8 $cinfo]] > 150} { + set cinfo [string range $cinfo 0 end-1] + } + append cinfo ... + } + set tail "\n (\"uplevel\" body line 1)\n invoked\ + from within\n\"uplevel 1 \$args\"" + set expect "$msg\n while executing\n\"$cinfo\"$tail" + if {$errInfo eq $expect} { + # + # The stack has only the eval from the expanded command + # Do not generate any stack trace here. + # + dict unset opts -errorinfo + dict incr opts -level + return -options $opts $msg + } + # + # Stack trace is nested, trim off just the contribution + # from the extra "eval" of $args due to the "catch" above. + # + set last [string last $tail $errInfo] + if {$last + [string length $tail] != [string length $errInfo]} { + # Very likely cannot happen + return -options $opts $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\"$cinfo\"" + set last [string last $tail $errInfo] + if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo $errInfo $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\n invoked from within\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + set tail "\n while executing\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + return -options $opts $msg + } else { + dict incr opts -level + return -options $opts $msg + } + } + } + #set isrepl [expr {[file tail [file rootname [info script]]] eq "repl"}] + set isrepl [punk::repl::codethread::is_running] ;#may not be reading though + if {$isrepl} { + #set ::tcl_interactive 1 + } + if {$isrepl || (([info level] == 1) && (([info script] eq "" ) ) + && ([info exists tcl_interactive] && $tcl_interactive))} { + if {![info exists auto_noexec]} { + set new [auto_execok $name] + if {$new ne ""} { + set redir "" + if {[namespace which -command console] eq ""} { + set redir ">&@stdout <@stdin" + } + + + #windows experiment todo - use twapi and named pipes + #twapi::namedpipe_server {\\.\pipe\something} + #Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones + #These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc + # + + if {[string first " " $new] > 0} { + set c1 $name + } else { + set c1 $new + } + + # -- --- --- --- --- + set idlist_stdout [list] + set idlist_stderr [list] + #set shellrun::runout "" + #when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] + + if {[dict get $::punk::config::running auto_exec_mechanism] eq "experimental"} { + #TODO - something cross-platform that allows us to maintain a separate console(s) with an additional set of IO channels to drive it + #not a trivial task + + #This runs external executables in a context in which they are not attached to a terminal + #VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output + #ctrl-c propagation also needs to be considered + + set teehandle punksh + uplevel 1 [list ::catch \ + [list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -inbuffering line -outbuffering none ] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + + if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" + } else { + #no point returning "exitcode 0" if that's the only non-error return. + #It is misleading. Better to return empty string. + set ::tcl::UnknownResult "" + } + } else { + set repl_runid [punk::get_repl_runid] + #set ::punk::last_run_display [list] + + set redir ">&@stdout <@stdin" + uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + #we can't detect stdout/stderr output from the exec + #for now emit an extra \n on stderr + #todo - there is probably no way around this but to somehow exec in the context of a completely separate console + #This is probably a tricky problem - especially to do cross-platform + # + # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit + if {[dict get $::tcl::UnknownOptions -code] == 0} { + set c green + set m "ok" + } else { + set c yellow + set m "errorCode $::errorCode" + } + set chunklist [list] + lappend chunklist [list "info" "[a $c]$m[a] " ] + if {$repl_runid != 0} { + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } + + } + + foreach id $idlist_stdout { + shellfilter::stack::remove stdout $id + } + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id + } + # -- --- --- --- --- + + + #uplevel 1 [list ::catch \ + # [concat exec $redir $new [lrange $args 1 end]] \ + # ::tcl::UnknownResult ::tcl::UnknownOptions] + + #puts "===exec with redir:$redir $::tcl::UnknownResult ==" + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + } + + if {$name eq "!!"} { + set newcmd [history event] + } elseif {[regexp {^!(.+)$} $name -> event]} { + set newcmd [history event $event] + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { + set newcmd [history event -1] + catch {regsub -all -- $old $newcmd $new newcmd} + } + if {[info exists newcmd]} { + tclLog $newcmd + history change $newcmd 0 + uplevel 1 [list ::catch $newcmd \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + + set ret [catch {set candidates [info commands $name*]} msg] + if {$name eq "::"} { + set name "" + } + if {$ret != 0} { + dict append opts -errorinfo \ + "\n (expanding command prefix \"$name\" in unknown)" + return -options $opts $msg + } + # Filter out bogus matches when $name contained + # a glob-special char [Bug 946952] + if {$name eq ""} { + # Handle empty $name separately due to strangeness + # in [string first] (See RFE 1243354) + set cmds $candidates + } else { + set cmds [list] + foreach x $candidates { + if {[string first $name $x] == 0} { + lappend cmds $x + } + } + } + + #punk - disable prefix match search + set default_cmd_search 0 + if {$default_cmd_search} { + if {[llength $cmds] == 1} { + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + if {[llength $cmds]} { + return -code error "ambiguous command name \"$name\": [lsort $cmds]" + } + } else { + #punk hacked version - report matches but don't run + if {[llength $cmds]} { + return -code error "unknown command name \"$name\": possible match(es) [lsort $cmds]" + } + + } + + + } + return -code error -errorcode [list TCL LOOKUP COMMAND $name] "invalid command name $name" + } + + proc know {cond body} { + set existing [info body ::unknown] + #assuming we can't test on cond being present in existing unknown script - because it may be fairly simple and prone to false positives (?) + ##This means we can't have 2 different conds with same body if we test for body in unknown. + ##if {$body ni $existing} { + 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. + proc ::unknown {args} [string map [list @c@ $cond @b@ $body @scr@ $scr] { + #--------------------------------------- + if {![catch {expr {@c@}} res] && $res} { + debug.punk.unknown {HANDLED BY: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 + return [eval {@b@}] + } else { + debug.punk.unknown {skipped: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 + } + #--------------------------------------- + }]$existing + #} + } + + proc know? {{len 2000}} { + puts [string range [info body ::unknown] 0 $len] + } + proc decodescript {b64} { + if {[ catch { + package require base64 + base64::decode $b64 + } scr]} { + return "" + } else { + return "($scr)" + } + } + + # --------------------------- + # commands that should be aliased in safe interps that need to use punk repl + # + proc get_repl_runid {} { + if {[interp issafe]} { + if {[info commands ::tsv::exists] eq ""} { + puts stderr "punk::get_repl_runid cannot operate directly in safe interp - install the appropriate punk aliases" + error "punk::get_repl_runid punk repl aliases not installed" + } + #if safe interp got here - there must presumably be a direct set of aliases on tsv::* commands + } + if {[tsv::exists repl runid]} { + return [tsv::get repl runid] + } else { + return 0 + } + } + #ensure we don't get into loop in unknown when in safe interp - which won't have tsv + proc set_repl_last_unknown {args} { + if {[interp issafe]} { + if {[info commands ::tsv::set] eq ""} { + puts stderr "punk::set_repl_last_unknown cannot operate directly in safe interp - install an alias to tsv::set repl last_unknown" + return + } + #tsv::* somehow working - possibly custom aliases for tsv functionality ? review + } + if {[info commands ::tsv::set] eq ""} { + puts stderr "set_repl_last_unknown - tsv unavailable!" + return + } + tsv::set repl last_unknown {*}$args + } + # --------------------------- + + + 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] + }][info body ::unknown] + + + #handle process return dict of form {exitcode num etc blah} + #ie when the return result as a whole is treated as a command + #exitcode must be the first key + know {[lindex $args 0 0] eq "exitcode"} { + uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] + } + + + #----------------------------- + # + # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. + + #todo - repl output info that it was evaluated as an expression + #know {[expr $args] || 1} {expr $args} + know {[expr $args] || 1} {tailcall expr $args} + + #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc + #punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) + know {[regexp {^([+-]*[0-9_]+)\.\.([+-]*[0-9_]+)$} [lindex $args 0 0] -> from to]} {punk::lib::range $from $to} + + + #NOTE: + #we don't allow setting namespace qualified vars in the lhs assignment pattern. + #The principle is that we shouldn't be setting vars outside of the immediate calling scope. + #(It would also be difficult and error-prone and generally make the pipelines less re-usable and reliable) + #Therefore ::nswhatever::blah= x is the pipeline: blah= x - where the corresponding command, if any is first resolved in ::nswhatever + #We will require that the namespace already exists - which is consistent with if the command were to be run without unknown + proc ::punk::_unknown_assign_dispatch {matchedon pattern equalsrhs args} { + set tail [lassign $args hd] + #puts "-> _unknown_assign_dispatch '$partzerozero' pattern:'$pattern' equalsrhs:'$equalsrhs' args:'$args' argshd:'$hd' argstail:'$tail'" + if {$hd ne $matchedon} { + if {[llength $tail]} { + error "unknown_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $tail" + } + #regexp $punk::re_assign $hd _ pattern equalsrhs + #we assume the whole pipeline has been provided as the head + #regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs tail + regexp {^([^\t\r\n=]*)\=([^\r\n]*)} $hd _ pattern fullrhs + lassign [_rhs_tail_split $fullrhs] equalsrhs tail + } + #NOTE: - it doesn't make sense to call 'namespace' qualifiers or 'namespace tail' on a compound hd such as v,::etc= blah + # we only look at leftmost namespace-like thing and need to take account of the pattern syntax + # e.g for ::etc,'::x'= + # the ns is :: and the tail is etc,'::x'= + # (Tcl's namespace qualifiers/tail won't help here) + if {[string match ::* $hd]} { + set patterns [punk::_split_patterns_memoized $hd] + #get a pair-list something like: {::x /0} {etc {}} + set ns [namespace qualifiers [lindex $patterns 0 0]] + set nslen [string length $ns] + set patterntail [string range $ns $nslen end] + } else { + set ns "" + set patterntail $pattern + } + if {[string length $ns] && ![namespace exists $ns]} { + error "unknown_assign_dispatch: namespace '$ns' not found. (Note that pipeline lhs variables cannot be namespaced)" + } else { + set nscaller [uplevel 1 [list ::namespace current]] + #jmn + set rhsmapped [pipecmd_namemapping $equalsrhs] + set commands [uplevel 1 [list ::info commands $pattern=$rhsmapped]] ;#uplevel - or else we are checking from perspective of this namespace ::punk + #we must check for exact match of the command in the list - because command could have glob chars. + if {"$pattern=$rhsmapped" in $commands} { + puts stderr "unknown_assign_dispatch>> '$pattern=$equalsrhs' $commands nscaller: '$nscaller'" + #we call the namespaced function - we don't evaluate it *in* the namespace. + #REVIEW + #warn for now...? + #tailcall $pattern=$equalsrhs {*}$args + tailcall $pattern=$rhsmapped {*}$tail + } + } + #puts "--->nscurrent [uplevel 1 [list ::namespace current]]" + #ignore the namespace.. + #We could interpret the fact that the nonexistant pipe was called with a namespace to indicate that's where the pipecommand should be created.. + #But.. we would need to ensure 1st (compiling) invocation runs the same way as subsequent invocations. + #namespace evaling match_assign here probably wouldn't accomplish that and may create surprises with regards to where lhs vars(if any) are created + tailcall ::punk::match_assign $patterntail $equalsrhs {*}$tail + #return [uplevel 1 [list ::punk::match_assign $varspecs $rhs $tail]] + } + #variable re_assign {^([^\r\n=\{]*)=(.*)} + #characters directly following = need to be assigned to the var even if they are escaped whitespace (e.g \t \r \n) + #unescaped whitespace causes the remaining elements to be part of the tail -ie are appended to the var as a list + #e.g x=a\nb c + #x will be assigned the list {a\nb c} ie the spaces between b & c are not maintained + # + #know {[regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + #know {[regexp {^{([^\t\r\n=]*)\=([^ \t\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + + + + proc ::punk::_unknown_compare {val1 val2 args} { + if {![string length [string trim $val2]]} { + if {[llength $args] > 1} { + #error "Extra args after comparison operator ==. usage e.g : \$var1==\$var2 or \$var1==\$var2 + 2" + set val2 [string cat {*}[lrange $args 1 end]] + return [expr {$val1 eq $val2}] + } + return $val1 + } elseif {[llength $args] == 1} { + #simple comparison + if {[string is digit -strict $val1$val2]} { + return [expr {$val1 == $val2}] + } else { + return [string equal $val1 $val2] + } + } elseif {![catch {expr $val2 {*}[lrange $args 1 end]} evaluated]} { + if {[string is digit -strict $val1$evaluated]} { + return [expr {$val1 == $evaluated}] + } else { + return [expr {$val1 eq $evaluated}] + } + } else { + set evaluated [uplevel 1 [list {*}$val2 {*}[lrange $args 1 end]]] + if {[string is digit -strict $val1$evaluated]} { + return [expr {$val1 == $evaluated}] + } else { + return [expr {$val1 eq $evaluated}] + } + } + } + #ensure == is after = in know sequence + #.* on left is pretty broad - todo: make it a little more specific to avoid unexpected interactions + know {[regexp {(.*)==(.*)} [lindex $args 0] _ val1 val2]} {tailcall ::punk::_unknown_compare $val1 $val2 {*}$args} + #.= must come after = here to ensure it comes before = in the 'unknown' proc + #set punk::re_dot_assign {([^=]*)\.=(.*)} + #know {[regexp $punk::re_dot_assign [lindex $args 0 0] _ varspecs rhs]} { + # set tail [expr {([lindex $args 0] eq [lindex $args 0 0]) ? [lrange $args 1 end] : [concat [lrange [lindex $args 0] 1 end] [lrange $args 1 end] ] }] + # tailcall ::punk::match_exec $varspecs $rhs {*}$tail + # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] + # } + # + + + + proc ::punk::_unknown_dot_assign_dispatch {partzerozero pattern equalsrhs args} { + #puts stderr ". unknown dispatch $partzerozero" + set argstail [lassign $args hd] + + #this equates to auto-flattening the head.. which seems like a bad idea, the structure was there for a reason. + #we should require explicit {*} expansion if the intention is for the args to be joined in at that level. + #expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } + + if {$hd ne $partzerozero} { + if {[llength $argstail]} { + error "unknown_dot_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $argstail" + } + #regexp $punk::re_assign $hd _ pattern equalsrhs + #we assume the whole pipeline has been provided as the head + #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail + #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail + + regexp {^([^ \t\r\n=\{]*)\.=([^\r\n]*)} $hd _ pattern fullrhs + lassign [_rhs_tail_split $fullrhs] equalsrhs argstail + } + #tailcall ::punk::match_assign $pattern $equalsrhs {*}$argstail + + + return [uplevel 1 [list ::punk::pipeline .= $pattern $equalsrhs {*}$argstail]] + + } + + # + know {[regexp {^([^\t\r\n=]*)\=([^\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + know {[regexp {^{([^\t\r\n=]*)\=([^\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + + #variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^\t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^\t\r\n=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + know {[regexp {^([^=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + + #add escaping backslashes to a value + #matching odd keys in dicts using pipeline syntax can be tricky - as + #e.g + #set ktest {a"b} + #@@[escv $ktest].= list a"b val + #without escv: + #@@"a\\"b".= list a"b val + #with more backslashes in keys the escv use becomes more apparent: + #set ktest {\\x} + #@@[escv $ktest].= list $ktest val + #without escv we would need: + #@@\\\\\\\\x.= list $ktest val + proc escv {v} { + #https://stackoverflow.com/questions/11135090/is-there-any-tcl-function-to-add-escape-character-automatically + #thanks to DKF + regsub -all {\W} $v {\\&} + } + interp alias {} escv {} punk::escv + #review + #set v "\u2767" + # + #escv $v + #\ + #the + + + #know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} { + # set argstail [lassign $args hd] + # #set tail [expr {($hd eq $partzerozero) ? $argstail : [concat [lrange $hd 1 end] $argstail ] }] ;#!WRONG. expr will convert some numbers to scientific notation - this is premature/undesirable! + # #avoid using the return from expr and it works: + # expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } + # + # tailcall ::punk::match_exec $varspecs $rhs {*}$tail + # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] + #} + + } + configure_unknown + #if client redefines 'unknown' after package require punk, they must call punk::configure_unknown afterwards. + # + + #main Pipe initiator function - needed especially if 'unknown' not configured to interpret x.= x= etc + #Should theoretically be slightly faster.. but pipelines are relatively slow until we can get pipeline compiling and optimisation. + proc % {args} { + set arglist [lassign $args assign] ;#tail, head + if {$assign eq ".="} { + tailcall {*}[list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + tailcall {*}[list ::punk::pipeline = "" "" {*}$arglist] + } + + set is_script [punk::arg_is_script_shaped $assign] + + if {!$is_script && [string index $assign end] eq "="} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + #set dumbeditor {\}} + if {[regexp {^([^ \t\r\n=\{]*)\.=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=\{]*)=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax punk::% unable to interpret pipeline '$args'" "% $args" [list pipesyntax unable_to_interpret] + } + } else { + if {$is_script} { + set cmdlist [list ::punk::pipeline "script" "" "" {*}$args] + } else { + set cmdlist [list ::punk::pipeline ".=" "" "" {*}$args] + } + } + tailcall {*}$cmdlist + + + #result-based mismatch detection can probably never work nicely.. + #we need out-of-band method to detect mismatch. Otherwise we can't match on mismatch results! + # + set result [uplevel 1 $cmdlist] + #pipeline result not guaranteed to be a proper list so we can't use list methods to directly look for 'binding mismatch' + #.. but if we use certain string methods - we shimmer the case where the main result is a list + #string match doesn't seem to change the rep.. though it does generate a string rep. + #puts >>1>[rep $result] + if {[catch {lrange $result 0 1} first2wordsorless]} { + #if we can't get as a list then it definitely isn't the semi-structured 'binding mismatch' + return $result + } else { + if {$first2wordsorless eq {binding mismatch}} { + error $result + } else { + #puts >>2>[rep $result] + return $result + } + } + } + + proc ispipematch {args} { + expr {[lindex [uplevel 1 [list pipematch {*}$args]] 0] eq "ok"} + } + + #pipe initiator which will never raise an error *except for pipesyntax* , but always returns {ok {result something}} or {error {mismatch something}} or, for tcl errors {error {reason something}} + proc pipematch {args} { + #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 + variable re_dot_assign + variable re_assign + + set arglist [lassign $args assign] + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + } elseif {![punk::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + # set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + # set dumbeditor {\}} + if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { + set cmdlist [list $assign {*}$arglist] + #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax punk::pipematch unable to interpret pipeline '$args'" "pipematch $args" [pipesyntax unable_to_interpret] + } + } else { + set cmdlist $args + #script? + #set cmdlist [list ::punk::pipeline .= "" "" {*}$args] + } + + if {[catch {uplevel 1 $cmdlist} result erroptions]} { + #puts stderr "pipematch erroptions:$erroptions" + #debug.punk.pipe {pipematch error $result} 4 + set ecode [dict get $erroptions -errorcode] + switch -- [lindex $ecode 0] { + binding { + if {[lindex $ecode 1] eq "mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + #return [dict create error [dict create mismatch $result]] + #puts stderr "pipematch converting error to {error {mismatch }}" + return [list error [list mismatch $result]] + } + } + pipesyntax { + #error $result + return -options $erroptions $result + } + casematch { + return $result + } + } + #return [dict create error [dict create reason $result]] + return [list error [list reason $result]] + } else { + return [list ok [list result $result]] + #debug.punk.pipe {pipematch result $result } 4 + #return [dict create ok [dict create result $result]] + } + } + + proc pipenomatchvar {varname args} { + if {[string first = $varname] >=0} { + #first word "pipesyntax" is looked for by pipecase + error "pipesyntax pipenomatch expects a simple varname as first argument" "pipenomatchvar $varname $args" [list pipesyntax expected_simple_varname] + } + #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 + + set assign [lindex $args 0] + set arglist [lrange $args 1 end] + if {[string first = $assign] >= 0} { + variable re_dot_assign + variable re_assign + #what if we get passed a script block containing = ?? e.g {error x=a} + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + } elseif {[regexp $re_dot_assign $assign _ returnvarspecs rhs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs $rhs {*}$arglist] + } elseif {[regexp $re_assign $assign _ returnvarspecs rhs]} { + set cmdlist [list ::punk::pipeline = $returnvarspecs $rhs {*}$arglist] + } else { + debug.punk.pipe {[a+ yellow bold] Unexpected arg following pipenomatchvar variable [a]} 0 + set cmdlist $args + #return [dict create error [dict create reason [dict create pipematch bad_first_word value $assign pipeline [list pipematch $assign {*}$args]]]] + } + } else { + set cmdlist $args + } + + upvar 1 $varname nomatchvar + if {[catch {uplevel 1 $cmdlist} result erroptions]} { + set ecode [dict get $erroptions -errorcode] + debug.punk.pipe {[a+ yellow bold]pipematchnomatch error $result[a]} 3 + if {[lindex $ecode 0] eq "pipesyntax"} { + set errordict [dict create error [dict create pipesyntax $result]] + set nomatchvar $errordict + return -options $erroptions $result + } + if {[lrange $ecode 0 1] eq "binding mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + set errordict [dict create error [dict create mismatch $result]] + set nomatchvar $errordict + return -options $erroptions $result + } + set errordict [dict create error [dict create reason $result]] + set nomatchvar $errordict + #re-raise the error for pipeswitch to deal with + return -options $erroptions $result + } else { + debug.punk.pipe {pipematchnomatch result $result } 4 + set nomatchvar "" + #uplevel 1 [list set $varname ""] + #return raw result only - to pass through to pipeswitch + return $result + #return [dict create ok [dict create result $result]] + } + } + + #should only raise an error for pipe syntax errors - all other errors should be wrapped + proc pipecase {args} { + #debug.punk.pipe {pipecase level [info level] levelinfo [info level 0]} 9 + set arglist [lassign $args assign] + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + #set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + set cmdlist [list ::= {*}$arglist] + } elseif {![punk::arg_is_script_shaped $assign] && [string first "=" $assign] >= 0} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + #set dumbeditor {\}} + + if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { + set cmdlist [list $assign {*}$arglist] + #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax pipecase unable to interpret pipeline '$args'" + } + #todo - account for insertion-specs e.g x=* x.=/0* + } else { + #script? + set cmdlist [list ::punk::pipeline .= "" "" {*}$args] + } + + + if {[catch {uplevel 1 [list ::if 1 $cmdlist]} result erroptions]} { + #puts stderr "====>>> result: $result erroptions" + set ecode [dict get $erroptions -errorcode] + switch -- [lindex $ecode 0] { + pipesyntax { + #error $result + return -options $erroptions $result + } + casenomatch { + return -options $erroptions $result + } + binding { + if {[lindex $ecode 1] eq "mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + #return [dict create error [dict create mismatch $result]] + # + #NOTE: casemismatch is part of the api for pipecase. It is a casemismatch rather than an error - because for a pipecase - a casemismatch is an expected event (many casemismatches - one match) + return [dict create casemismatch $result] + } + } + } + + #we can't always treat $result as a list - may be an error string which can't be represented as a list, and there may be no useful errorCode + #todo - use errorCode instead + if {[catch {lindex $result 0} word1]} { + #tailcall error $result + return -options $erroptions $result + } else { + switch -- $word1 { + switcherror - funerror { + error $result "pipecase [lsearch -all -inline $args "*="]" + } + resultswitcherror - resultfunerror { + #recast the error as a result without @@ok wrapping + #use the tailcall return to stop processing other cases in the switch! + tailcall return [dict create error $result] + } + ignore { + #suppress error, but use normal return + return [dict create error [dict create suppressed $result]] + } + default { + #normal tcl error + #return [dict create error [dict create reason $result]] + tailcall error $result "pipecase $args" [list caseerror] + } + } + } + } else { + tailcall return -errorcode [list casematch] [dict create ok [dict create result $result]] + } + + } + + #note that pipeswitch deliberately runs in callers scope to have direct access to variables - it is akin to a control structure. + #It also - somewhat unusually accepts args - which we provide as 'switchargs' + #This is unorthodox/risky in that it will clobber any existing var of that name in callers scope. + #Solve using documentation.. consider raising error if 'switchargs' already exists, which would require user to unset switchargs in some circumstances. + proc pipeswitch {pipescript args} { + #set nextargs $args + #unset args + #upvar args upargs + #set upargs $nextargs + upvar switchargs switchargs + set switchargs $args + uplevel 1 [::list ::if 1 $pipescript] + } + #static-closure version - because we shouldn't be writing back to calling context vars directly + #Tcl doesn't (2023) have mutable closures - but for functional pipeline composition - we probably don't want that anyway! + #pipeswitchc is preferable to pipeswitch in that we can access context without risk of affecting it, but is less performant. (particularly in global scope.. but that probably isn't an important usecase) + proc pipeswitchc {pipescript args} { + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list info vars] + } else { + set get_vars [list info locals] + } + set vars [uplevel 1 {*}$get_vars] + set posn [lsearch $vars switchargs] + set vars [lreplace $vars $posn $posn] + foreach v $vars { + upvar 1 $v var + if {(![array exists var]) && [info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + lappend binding [list switchargs $args] + apply [list $binding $pipescript [uplevel 1 {::namespace current}]] + } + + proc pipedata {data args} { + #puts stderr "'$args'" + set r $data + for {set i 0} {$i < [llength $args]} {incr i} { + set e [lindex $args $i] + #review: string is list is as slow as catch {llength $e} - and also affects ::errorInfo unlike other string is commands. bug/enhancement report? + if {![string is list $e]} { + #not a list - assume script and run anyway + set r [apply [list {data} $e] $r] + } else { + if {[llength $e] == 1} { + switch -- $e { + > { + #output to calling context. only pipedata return value and '> varname' should affect caller. + incr i + uplevel 1 [list set [lindex $args $i] $r] + } + % - pipematch - ispipematch { + incr i + set e2 [lindex $args $i] + #set body [list $e {*}$e2] + #append body { $data} + + set body [list $e {*}$e2] + append body { {*}$data} + + + set applylist [list {data} $body] + #puts stderr $applylist + set r [apply $applylist $r] + } + pipeswitch - pipeswitchc { + #pipeswitch takes a script not a list. + incr i + set e2 [lindex $args $i] + set body [list $e $e2] + #pipeswitch takes 'args' - so expand $data when in pipedata context + append body { {*}$data} + #use applylist instead of uplevel when in pipedata context! + #can use either switchdata/data but not vars in calling context of 'pipedata' command. + #this is consistent with pipeswitch running in a % / .= pipeline which can only access vars in immediate calling context. + set applylist [list {data} $body] + #puts stderr $applylist + set r [apply $applylist $r] + } + default { + #puts "other single arg: [list $e $r]" + append e { $data} + set r [apply [list {data} $e] $r] + } + } + } elseif {[llength $e] == 0} { + #do nothing - pass data through + #leave r as is. + } else { + set r [apply [list {data} $e] $r] + } + } + } + return $r + } + + + proc scriptlibpath {{shortname {}} args} { + upvar ::punk::config::running running_config + set scriptlib [dict get $running_config scriptlib] + if {[string match "lib::*" $shortname]} { + set relpath [string map [list "lib::" "" "::" "/"] $shortname] + set relpath [string trimleft $relpath "/"] + set fullpath $scriptlib/$relpath + } else { + set shortname [string trimleft $shortname "/"] + set fullpath $scriptlib/$shortname + } + return $fullpath + } + + + #useful for aliases e.g treemore -> xmore tree + proc xmore {args} { + if {[llength $args]} { + uplevel #0 [list {*}$args | more] + } else { + error "usage: punk::xmore args where args are run as {*}\$args | more" + } + } + + + #environment path as list + # + #return *appendable* pipeline - i.e no args via <| + proc path_list_pipe {{glob *}} { + if {$::tcl_platform(platform) eq "windows"} { + set sep ";" + } else { + # : ok for linux/bsd ... mac? + set sep ":" + } + set cond [string map [list $glob] {expr {[string length $item] && [string match $item]}}] + #env members such as ''path' not case sensitive on windows - but are on some other platforms (at least FreeBSD) + return [list .= set ::env(PATH) |> .=>2 string trimright $sep |> .=>1 split $sep |> list_filter_cond $cond ] + } + proc path_list {{glob *}} { + set pipe [punk::path_list_pipe $glob] + {*}$pipe + } + proc path {{glob *}} { + set pipe [punk::path_list_pipe $glob] + {*}$pipe |> list_as_lines + } + + #------------------------------------------------------------------- + #sh 'test' equivalent - to be used with exitcode of process + # + + #single evaluation to get exitcode + proc sh_test {args} { + set a1 [lindex $args 0] + if {$a1 in [list -b -c -d -e -f -h -L -s -S -x -w]} { + set a2 [lindex $args 1] + if {![catch { + set attrinfo [file attributes $a2] + } errM]} { + if {[dict exists $attrinfo -vfs] && [dict get $attrinfo -vfs] == 1} { + puts stderr "WARNING: external 'test' being called on vfs path. External command will probably not have access to the vfs. Use 'TEST' for Tcl view of vfs mounted filesystems." + } + } + } + tailcall run test {*}$args + } + + #whether v is an integer from perspective of unix test command. + #can be be bigger than a tcl int or wide ie bignum - but must be whole number + #test doesn't handle 1.0 - so we shouldn't auto-convert + proc is_sh_test_integer {v} { + if {[string first . $v] >=0 || [string first e $v] >= 0} { + return false + } + #if it is double but not sci notation and has no dots - then we can treat as a large integer for 'test' + if {[string is double -strict $v]} { + return true + } else { + return false + } + } + #can use double-evaluation to get true/false + #faster tcl equivalents where possible to accuratley provide, and fallthrough to sh for compatibility of unimplemented + #The problem with fallthrough is that sh/bash etc have a different view of existant files + #e.g unix files such as /dev/null vs windows devices such as CON,PRN + #e.g COM1 is mapped as /dev/ttyS1 in wsl (?) + #Note also - tcl can have vfs mounted file which will appear as a directory to Tcl - but a file to external commands! + #We will stick with the Tcl view of the file system. + #User can use their own direct calls to external utils if + #Note we can't support $? directly in Tcl - script would have to test ${?} or use [set ?] + proc sh_TEST {args} { + upvar ? lasterr + set lasterr 0 + set a1 [lindex $args 0] + set a2 [lindex $args 1] + set a3 [lindex $args 2] + set fileops [list -b -c -d -e -f -h -L -s -S -x -w] + if {[llength $args] == 1} { + #equivalent of -n STRING + set boolresult [expr {[string length $a1] != 0}] + } elseif {[llength $args] == 2} { + if {$a1 in $fileops} { + if {$::tcl_platform(platform) eq "windows"} { + #e.g trailing dot or trailing space + if {[punk::winpath::illegalname_test $a2]} { + #protect with \\?\ to stop windows api from parsing + #will do nothing if already prefixed with \\?\ + + set a2 [punk::winpath::illegalname_fix $a2] + } + } + } + switch -- $a1 { + -b { + #dubious utility on FreeBSD, windows? + #FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' + #Linux apparently uses them though + if{[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "blockSpecial"}] + } else { + set boolresult false + } + } + -c { + #e.g on windows CON,NUL + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "characterSpecial"}] + } else { + set boolresult false + } + } + -d { + set boolresult [file isdirectory $a2] + } + -e { + set boolresult [file exists $a2] + } + -f { + #e.g on windows CON,NUL + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "file"}] + } else { + set boolresult false + } + } + -h - + -L { + set boolresult [expr {[file type $a2] eq "link"}] + } + -s { + set boolresult [expr {[file exists $a2] && ([file size $a2] > 0 )}] + } + -S { + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "socket"}] + } else { + set boolresult false + } + } + -x { + set boolresult [expr {[file exists $a2] && [file executable $a2]}] + } + -w { + set boolresult [expr {[file exists $a2] && [file writable $a2]}] + } + -z { + set boolresult [expr {[string length $a2] == 0}] + } + -n { + set boolresult [expr {[string length $a2] != 0}] + } + default { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + } + } + } elseif {[llength $args] == 3} { + switch -- $a2 { + "=" { + #test does string comparisons + set boolresult [string equal $a1 $a3] + } + "!=" { + #string comparison + set boolresult [expr {$a1 ne $a3}] + } + "-eq" { + #test expects a possibly-large integer-like thing + #shell scripts will + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 == $a3}] + } + "-ge" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 >= $a3}] + } + "-gt" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 > $a3}] + } + "-le" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 <= $a3}] + } + "-lt" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 < $a3}] + } + "-ne" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 != $a3}] + } + default { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + + } + } + } else { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + } + + #normalize 1,0 etc to true,false + #we want to make it obvious we are not just reporting exitcode 0 for example - which represents true in tcl. + if {$boolresult} { + return true + } else { + if {$lasterr == 0} { + set lasterr 1 + } + return false + } + + + } + proc sh_echo {args} { + tailcall run echo {*}$args + } + proc sh_ECHO {args} { + #execute the result of the run command - which is something like: 'exitcode n' - to get true/false + tailcall apply {arglist {uplevel #0 [run echo {*}$arglist]} ::} $args + } + + + #sh style true/false for process exitcode. 0 is true - everything else false + proc exitcode {args} { + set c [lindex $args 0] + if {[string is integer -strict $c]} { + #return [expr {$c == 0}] + #return true/false to make it clearer we are outputting tcl-boolean inverse mapping from the shell style 0=true + if {$c == 0} { + return true + } else { + return false + } + } else { + return false + } + } + #------------------------------------------------------------------- + + namespace export help aliases alias exitcode % pipedata pipecase pipeline pipematch pipeswitch pipeswitchc pipecase linelist linesort inspect list_as_lines val treemore + + #namespace ensemble create + + + + + #tilde + #These aliases work fine for interactive use - but the result is always a string int-rep + #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) + #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} + proc ~ {args} { + set hdir [punk::objclone $::env(HOME)] + file pathtype $hdir + set d $hdir + #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions + foreach a $args { + set d [file join $d $a] + } + file pathtype $d + return [punk::objclone $d] + } + interp alias {} ~ {} punk::~ + + + #maint - punk::args has similar + #this is largely obsolete - uses dict for argspecs (defaults) instead of textblock as in punk::args + #textblock has more flexibility in some ways - but not as easy to manipulate especially with regards to substitutions + #todo - consider a simple wrapper for punk::args to allow calling with dict of just name and default? + #JMN + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + #TODO - remove + proc get_leading_opts_and_values {defaults rawargs args} { + if {[llength $defaults] %2 != 0} { + error "get_leading_opts_and_values expected first argument 'defaults' to be a dictionary" + } + dict for {k v} $defaults { + if {![string match -* $k]} { + error "get_leading_opts_and_values problem with supplied defaults. Expect each key to begin with a dash. Got key '$k'" + } + } + #puts "--> [info frame -2] <--" + set cmdinfo [dict get [info frame -2] cmd] + #we can't treat cmdinfo as a list - it may be something like {command {*}$args} in which case lindex $cmdinfo 0 won't work + #hopefully first word is a plain proc name if this function was called in the normal manner - directly from a proc + #we will break at first space and assume the lhs of that will give enough info to be reasonable - (alternatively we could use entire cmdinfo - but it might be big and ugly) + set caller [regexp -inline {\S+} $cmdinfo] + + #if called from commandline or some other contexts such as outside of a proc in a namespace - caller may just be "namespace" + if {$caller eq "namespace"} { + set caller "get_leading_opts_and_values called from namespace" + } + + # ------------------------------ + if {$caller ne "get_leading_opts_and_values"} { + #check our own args + lassign [get_leading_opts_and_values {-anyopts 0 -minvalues 0 -maxvalues -1} $args] _o ownopts _v ownvalues + if {[llength $ownvalues] > 0} { + error "get_leading_opts_and_values expected: a dictionary of defaults, a list of args and at most two option pairs -minvalues and -maxvalues - got extra arguments: '$ownvalues'" + } + set opt_minvalues [dict get $ownopts -minvalues] + set opt_maxvalues [dict get $ownopts -maxvalues] + set opt_anyopts [dict get $ownopts -anyopts] + } else { + #don't check our own args if we called ourself + set opt_minvalues 0 + set opt_maxvalues 0 + set opt_anyopts 0 + } + # ------------------------------ + + if {[set eopts [lsearch $rawargs "--"]] >= 0} { + set values [lrange $rawargs $eopts+1 end] + set arglist [lrange $rawargs 0 $eopts-1] + } else { + if {[lsearch $rawargs -*] >= 0} { + #to support option values with leading dash e.g -offset -1 , we can't just take the last flagindex + set i 0 + foreach {k v} $rawargs { + if {![string match -* $k]} { + break + } + if {$i+1 >= [llength $rawargs]} { + #no value for last flag + error "bad options for $caller. No value supplied for last option $k" + } + incr i 2 + } + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + } else { + set values $rawargs ;#no -flags detected + set arglist [list] + } + } + if {$opt_maxvalues == -1} { + #only check min + if {[llength $values] < $opt_minvalues} { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected at least $opt_minvalues" + } + } else { + if {[llength $values] < $opt_minvalues || [llength $values] > $opt_maxvalues} { + if {$opt_minvalues == $opt_maxvalues} { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected exactly $opt_minvalues" + } else { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected between $opt_minvalues and $opt_maxvalues inclusive" + } + } + } + + if {!$opt_anyopts} { + set checked_args [dict create] + for {set i 0} {$i < [llength $arglist]} {incr i} { + #allow this to error out with message indicating expected flags + dict set checked_args [tcl::prefix match -message "options for $caller. Unexpected option" [dict keys $defaults] [lindex $arglist $i]] [lindex $arglist $i+1] + incr i ;#skip val + } + } else { + set checked_args $arglist + } + set opts [dict merge $defaults $checked_args] + + #maintain order of opts $opts values $values as caller may use lassign. + return [dict create opts $opts values $values] + } + + + + + + + + + + #-------------------------------------------------- + #some haskell-like operations + #group equivalent + #http://zvon.org/other/haskell/Outputlist/group_f.html + #as we can't really distinguish a single element list from a string we will use 2 functions + proc group_list1 {lst} { + set out [list] + set prev [lindex $lst 0] + set g [list] + foreach i $lst { + if {$i eq $prev} { + lappend g $i + } else { + lappend out $g + set g [list $i] + } + set prev $i + } + lappend out $g + return $out + } + proc group_list {lst} { + set out [list] + set next [lindex $lst 1] + set tail [lassign $lst x] + set g [list $x] + set y [lindex $tail 0] + set last_condresult [expr {$x}] + set n 1 ;#start at one instead of zero for lookahead + foreach x $tail { + set y [lindex $tail $n] + set condresult [expr {$x}] + if {$condresult eq $last_condresult} { + lappend g $x + } else { + lappend out $g + set g [list $x] + set last_condresult $condresult + } + incr n + } + lappend out $g + return $out + } + + #NOT attempting to match haskell other than in overall concept. + # + #magic var-names are a bit of a code-smell. But submitting only an expr argument is more Tcl-like than requiring an 'apply' specification. + #Haskell seems to take an entire lambda so varnames can be user-specified - but the 'magic' there is in it's choice of submitting 2 elements at a time + #We could do similar .. but we'll focus on comprehensibility for the basic cases - especially as begginning and end of list issues could be confusing. + # + #vars: index prev, prev0, prev1, item, next, next0, next1,nextr, cond + #(nextr is a bit obscure - but basically means next-repeat ie if no next - use same value. just once though.) + #group by cond result or first 3 wordlike parts of error + #e.g group_list_by {[lindex $item 0]} {{a 1} {a 2} {b 1}} + proc group_list_by {cond lst} { + set out [list] + set prev [list] + set next [lindex $lst 1] + set tail [lassign $lst item] + set g [list $item] + set next [lindex $tail 0] + if {$prev eq ""} { + set prev0 0 + set prev1 1 + set prevr $item + } else { + set prev0 $prev + set prev1 $prev + set prevr $prev + } + if {$next eq ""} { + set next0 0 + set next1 1 + set nextr $item + } else { + set next0 $next + set next1 $next + set nextr $next + } + set last_condresult [apply {{index cond prev prev0 prev1 prevr item next next0 next1 nextr} { + if {[catch {expr $cond} r]} { + puts stderr "index: 0 ERROR $r" + set wordlike_parts [regexp -inline -all {\S+} $r] + set r [list ERROR {*}[lrange $wordlike_parts 0 2]] + } + set r + } + } 0 $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] + set n 1 ;#start at one instead of zero for lookahead + #note - n also happens to matchi zero-based index of original list + set prev $item + foreach item $tail { + set next [lindex $tail $n] + if {$prev eq ""} { + set prev0 0 + set prev1 1 + set prevr $item + } else { + set prev0 $prev + set prev1 $prev + set prevr $prev + } + if {$next eq ""} { + set next0 0 + set next1 1 + set nextr $item + } else { + set next0 $next + set next1 $next + set nextr $next + } + set condresult [apply {{index cond prev prev0 prev1 prevr item next next0 next1 nextr} { + if {[catch {expr $cond} r]} { + puts stderr "index: $index ERROR $r" + set wordlike_parts [regexp -inline -all {\S+} $r] + set r [list ERROR {*}[lrange $wordlike_parts 0 2]] + } + set r + } + } $n $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] + if {$condresult eq $last_condresult} { + lappend g $item + } else { + lappend out $g + set g [list $item] + set last_condresult $condresult + } + incr n + set prev $item + } + lappend out $g + return $out + } + + #group_numlist ? preserve representation of numbers rather than use string comparison? + + + # - group_string + #.= punk::group_string "aabcccdefff" + # aa b ccc d e fff + proc group_string {str} { + lmap v [group_list [split $str ""]] {string cat {*}$v} + } + + #lists may be of unequal lengths + proc transpose_lists {list_rows} { + set res {} + #set widest [pipedata $list_rows {lmap v $data {llength $v}} {tcl::mathfunc::max {*}$data}] + set widest [tcl::mathfunc::max {*}[lmap v $list_rows {llength $v}]] + for {set j 0} {$j < $widest} {incr j} { + set newrow {} + foreach oldrow $list_rows { + if {$j >= [llength $oldrow]} { + continue + } else { + lappend newrow [lindex $oldrow $j] + } + } + lappend res $newrow + } + return $res + } + proc transpose_strings {list_of_strings} { + set charlists [lmap v $list_of_strings {split $v ""}] + set tchars [transpose_lists $charlists] + lmap v $tchars {string cat {*}$v} + } + + package require struct::matrix + #transpose a serialized matrix using the matrix command + #Note that we can have missing row values below and to right + #e.g + #a + #a b + #a + proc transpose_matrix {matrix_rows} { + set mcmd [struct::matrix] + #serialization format: numcols numrows rowlist + set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] + $mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] + $mcmd transpose + set result [lindex [$mcmd serialize] 2] ;#strip off dimensions + $mcmd destroy + return $result + } + + set objname [namespace current]::matrixchain + if {$objname ni [info commands $objname]} { + oo::class create matrixchain { + variable mcmd + constructor {matrixcommand} { + puts "wrapping $matrixcommand with [self]" + set mcmd $matrixcommand + } + destructor { + puts "matrixchain destructor called for [self] (wrapping $mcmd)" + $mcmd destroy + } + method unknown {args} { + if {[llength $args]} { + switch -- [lindex $args 0] { + add - delete - insert - transpose - sort - set - swap { + $mcmd {*}$args + return [self] ;#result is the wrapper object for further chaining in pipelines + } + default { + tailcall $mcmd {*}$args + } + } + } else { + #will error.. but we should pass that on + tailcall $mcmd + } + } + } + } + + #review + #how do we stop matrix pipelines from leaving commands around? i.e how do we call destroy on the matrixchain wrapper if not explicitly? + #Perhaps will be solved by: Tip 550: Garbage collection for TclOO + #Theoretically this should allow tidy up of objects created within the pipeline automatically + #If the object name is placed in the pipeline variable dict then it should survive across segment apply scripts and only go out of scope at the end. + proc matrix_command_from_rows {matrix_rows} { + set mcmd [struct::matrix] + set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] + $mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] + #return $mcmd + set wrapper [punk::matrixchain new $mcmd] + } + + #-------------------------------------------------- + + proc list_filter_cond {itemcond listval} { + set filtered_list [list] + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list ::info vars] + } else { + set get_vars [list ::info locals] + } + set vars [uplevel 1 {*}$get_vars] + set posn [lsearch $vars item] + set vars [lreplace $vars $posn $posn] + foreach v $vars { + upvar 1 $v var + if {(![array exists var]) && [info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + #lappend binding [list item $args] + + #puts stderr "binding: [join $binding \n]" + #apply [list $binding $pipescript [uplevel 1 ::namespace current]] + foreach item $listval { + set bindlist [list {*}$binding [list item $item]] + if {[apply [list $bindlist $itemcond [uplevel 1 ::namespace current]] ]} { + lappend filtered_list $item + } + } + return $filtered_list + } + + + proc ls {args} { + if {![llength $args]} { + set args [list [pwd]] + } + if {[llength $args] ==1} { + return [glob -nocomplain -tails -dir [lindex $args 0] *] + } else { + set result [dict create] + foreach a $args { + set k [file normalize $a] + set contents [glob -nocomplain -tails -dir $a *] + dict set result $k $contents + } + return $result + } + } + + + + #linelistraw is essentially split $text \n so is only really of use for pipelines, where the argument order is more convenient + #like linelist - but keeps leading and trailing empty lines + #single \n produces {} {} + #the result can be joined to reform the arg if a single arg supplied + # + proc linelistraw {args} { + set linelist [list] + foreach {a} $args { + set nlsplit [split $a \n] + lappend linelist {*}$nlsplit + } + #return [split $text \n] + return $linelist + } + proc linelist1 {args} { + set linelist [list] + foreach {a} $args { + set nlsplit [split $a \n] + set start 0 + set end "end" + + if {[lindex $nlsplit 0] eq ""} { + set start 1 + } + if {[lindex $nlsplit end] eq ""} { + set end "end-1" + } + set alist [lrange $nlsplit $start $end] + lappend linelist {*}$alist + } + return $linelist + } + + + #An implementation of a notoriously controversial metric. + proc LOC {args} { + set argspecs [subst { + -dir -default "\uFFFF" + -exclude_dupfiles -default 1 -type boolean + -exclude_punctlines -default 1 -type boolean + -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } + }] + set argd [punk::args::get_dict $argspecs $args] + lassign [dict values $argd] leaders opts vals + set searchspecs [dict values $vals] + + # -- --- --- --- --- --- + 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 filepaths [punk::path::treefilenames -dir $opt_dir {*}$searchspecs] + set loc 0 + set dupfileloc 0 + set seentails [list] + set dupfilecount 0 + set extensions [list] + set purepunctlines 0 + foreach fpath $filepaths { + set isdupfile 0 + set floc 0 + set fpurepunctlines 0 + set ext [file extension $fpath] + if {$ext ni $extensions} { + lappend extensions $ext + } + if {!$opt_exclude_punctlines} { + set floc [llength [linelist -line {trimright} -block {trimall} [fcat $fpath]]] + } else { + set lines [linelist -line {trimright} -block {trimall} [fcat $fpath]] + set mapawaypunctuation [list] + foreach p $opt_punctchars empty {} { + lappend mapawaypunctuation $p $empty + } + foreach ln $lines { + if {[string length [string trim [string map $mapawaypunctuation $ln]]] > 0} { + incr floc + } else { + incr fpurepunctlines + } + } + } + if {[file tail $fpath] in $seentails} { + 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] + } + if {$opt_exclude_punctlines} { + return [list loc $loc filecount [llength $filepaths] dupfiles $dupfilecount dupfileloc $dupfileloc extensions $extensions purepunctuationlines $purepunctlines] + } + return [list loc $loc filecount [llength $filepaths] dupfiles $dupfilecount dupfileloc $dupfileloc extensions $extensions] + } + + + + #!!!todo fix - linedict is unfinished and non-functioning + #linedict based on indents + proc linedict {args} { + set data [lindex $args 0] + 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" + foreach ln $nlsplit { + if {![string length [string trim $ln]]} { + incr i + continue + } + set is_rootkey 0 + 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 {$this_indent == $rootindent} { + set is_rootkey 1 + } + if {$this_indent < $rootindent} { + error "bad root indentation ($this_indent) at line: $i smallest indent was set by first key line: $firstkeyline" + } + if {$is_rootkey} { + dict set d $linedata {} + lappend keys $linedata + } else { + if {$stepindent < 0} { + set stepindent $this_indent + set firststepline $ln + } + if {$this_indent == $stepindent} { + dict set d [lindex $keys end] $ln + } 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" + } + + #todo fix! + 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] + } else { + dict set d $parentkey $ln + } + + } + } + incr i + } + return $d + } + proc dictline {d} { + puts stderr "unimplemented" + set lines [list] + + return $lines + } + + + proc ooinspect {obj} { + set obj [uplevel 1 [list namespace which -command $obj]] + set isa [lmap type {object class metaclass} { + if {![info object isa $type $obj]} continue + set type + }] + foreach tp $isa { + switch -- $tp { + class { + lappend info {class superclasses} {class mixins} {class filters} + lappend info {class methods} {class methods} + lappend info {class variables} {class variables} + } + object { + lappend info {object class} {object mixins} {object filters} + lappend info {object methods} {object methods} + lappend info {object variables} {object variables} + lappend info {object namespace} {object vars} ;#{object commands} + } + } + } + + set result [dict create isa $isa] + foreach args $info { + dict set result $args [info {*}$args $obj] + foreach opt {-private -all} { + catch { + dict set result [list {*}$args $opt] [info {*}$args $obj $opt] + } + } + } + dict filter $result value {?*} + } + + punk::args::define { + @id -id ::punk::inspect + @cmd -name punk::inspect -help\ + "Function to display values - used pimarily in a punk pipeline. + The raw value arguments (not options) are always returned to pass + forward in the pipeline. + (pipeline data inserted at end of each |...> segment is passed as single item unless + inserted with an expanding insertion specifier such as .=>* ) + e.g1: + .= list a b c |v1,/1-end,/0>\\ + .=>* inspect -label i1 -- |>\\ + .=v1> inspect -label i2 -- |>\\ + string toupper + (3) i1: {a b c} {b c} a + (1) i2: a b c + + - A B C + " + -label -type string -default "" -help\ + "An optional label to help distinguish output when multiple + inspect statements are in a pipeline. This appears after the + bracketed count indicating number of values supplied. + e.g (2) MYLABEL: val1 val2 + The label can include ANSI codes. + e.g + inspect -label [a+ red]mylabel -- val1 val2 val3 + " + -limit -type int -default 20 -help\ + "When multiple values are passed to inspect - limit the number + of elements displayed in -channel output. + When truncation has occured an elipsis indication (...) will be appended. + e.g + .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ + (11) 20 23 26 29... + + - 385 + + For no limit - use -limit -1 + " + -channel -type string -default stderr -help\ + "An existing open channel to write to. If value is any of nul, null, /dev/nul + the channel output is disabled. This effectively disables inspect as the args + are simply passed through in the return to continue the pipeline. + " + -showcount -type boolean -default 1 -help\ + "Display a leading indicator in brackets showing the number of arg values present." + -ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels { + 0 "Strip ANSI codes from display + of values. The disply output will + still be colourised if -ansibase has + not been set to empty string or + [a+ normal]. The stderr or stdout + channels may also have an ansi colour. + (see 'colour off' or punk::config)" + 1 "Leave value as is" + 2 "Display the ANSI codes and + other control characters inline + with replacement indicators. + e.g esc, newline, space, tab" + VIEW "Alias for 2" + 3 "Display as per 2 but with + colourised ANSI replacement codes." + VIEWCODES "Alias for 3" + 4 "Display ANSI and control + chars in default colour, but + apply the contained ansi to + the text portions so they display + as they would for -ansi 1" + VIEWSTYLE "Alias for 4" + } + -ansibase -type ansistring -default {${[a+ brightgreen]}} -help\ + "Base ansi code(s) that will apply to output written to the chosen -channel. + If there are ansi resets in the displayed values - output will revert to this base. + Does not affect return value." + -- -type none -help\ + "End of options marker. + It is advisable to use this, as data in a pipeline may often begin with -" + + @values -min 0 -max -1 + arg -type string -optional 1 -multiple 1 -help\ + "value to display" + } + #pipeline inspect + #e.g + #= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data} + proc inspect {args} { + set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1 -ansibase [a+ brightgreen]] + set flags [list] + set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect -- + if {$endoptsposn >= 0} { + set flags [lrange $args 0 $endoptsposn-1] + set pipeargs [lrange $args $endoptsposn+1 end] + } else { + #no explicit end of opts marker + #last trailing elements of args after taking *known* -tag v pairs is the value to inspect + for {set i 0} {$i < [llength $args]} {incr i} { + set k [lindex $args $i] + if {$k in [dict keys $defaults]} { + lappend flags {*}[lrange $args $i $i+1] + incr i + } else { + #first unrecognised option represents end of flags + break + } + } + set pipeargs [lrange $args $i end] + } + foreach {k v} $flags { + if {$k ni [dict keys $defaults]} { + #error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" + punk::args::get_by_id ::punk::inspect $args + } + } + set opts [dict merge $defaults $flags] + # -- --- --- --- --- + set label [dict get $opts -label] + set channel [dict get $opts -channel] + set showcount [dict get $opts -showcount] + if {[string length $label]} { + set label "${label}: " + } + set limit [dict get $opts -limit] + set opt_ansiraw [dict get $opts -ansi] + set opt_ansi [tcl::prefix::match -error "" [list 0 1 2 3 4 view viewcodes viewstyle] [string tolower $opt_ansiraw]] + switch -- [string tolower $opt_ansi] { + 0 - 1 - 2 - 3 - 4 {} + view {set opt_ansi 2} + viewcodes {set opt_ansi 3} + viewstyle {set opt_ansi 4} + default { + error "inspect -ansi 0|1|2|view|3|viewcodes|4|viewstyle - received -ansi $opt_ansiraw" + } + } + # -- --- --- --- --- + + set more "" + if {[llength $pipeargs] == 1} { + #usual case is data as a single element + set val [lindex $pipeargs 0] + set count 1 + } else { + #but the pipeline segment could have an insertion-pattern ending in * + set val $pipeargs + set count [llength $pipeargs] + } + switch -- [string tolower $channel] { + nul - null - /dev/null { + return $val + } + } + set displayval $val ;#default - may be overridden based on -limit + + if {$count > 1} { + #val is a list + set llen [llength $val] + if {$limit > 0 && ($limit < $llen)} { + set displayval [lrange $val 0 $limit-1] + if {$llen > $limit} { + set more "..." + } + } + } else { + #not a valid tcl list - limit by lines + if {$limit > 0} { + set rawlines [split $val \n] + set llen [llength $rawlines] + set displaylines [lrange $rawlines 0 $limit-1] + set displayval [join $displaylines "\n"] + if {$llen > $limit} { + set more "\n..." + } + } + + } + if {$showcount} { + set displaycount "[a purple bold]($count)[a] " + if {$showcount} { + set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space + set margin [string repeat " " $countspace] + set displayval [string map [list \r "" \n "\n$margin"] $displayval] + } + } else { + set displaycount "" + } + + set ansibase [dict get $opts -ansibase] + if {$ansibase ne ""} { + #-ansibase default is hardcoded into punk::args definition + #run a test using any ansi code to see if colour is still enabled + if {[a+ red] eq ""} { + set ansibase "" ;#colour seems to be disabled + } + } + + switch -- $opt_ansi { + 0 { + set displayval $ansibase[punk::ansi::ansistrip $displayval] + } + 1 { + #val may have ansi - including resets. Pass through ansibase_lines to + if {$ansibase ne ""} { + set displayval [::textblock::ansibase_lines $displayval $ansibase] + } + } + 2 { + set displayval $ansibase[ansistring VIEW $displayval] + if {$ansibase ne ""} { + set displayval [::textblock::ansibase_lines $displayval $ansibase] + } + } + 3 { + set displayval $ansibase[ansistring VIEWCODE $displayval] + if {$ansibase ne ""} { + set displayval [::textblock::ansibase_lines $displayval $ansibase] + } + } + 4 { + set displayval $ansibase[ansistring VIEWSTYLE $displayval] + if {$ansibase ne ""} { + set displayval [::textblock::ansibase_lines $displayval $ansibase] + } + } + } + + if {![string length $more]} { + puts $channel "$displaycount$label$displayval[a]" + } else { + puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + } + return $val + } + + + + #return list of {chan chunk} elements + proc help_chunks {args} { + set chunks [list] + set linesep [string repeat - 76] + set mascotblock "" + catch { + package require patternpunk + #lappend chunks [list stderr [>punk . rhs]] + append mascotblock [textblock::frame -checkargs 0 [>punk . banner -title "Punk Shell" -left Tcl -right [package provide Tcl]]] + } + + set topic [lindex $args end] + set argopts [lrange $args 0 end-1] + + + set title "[a+ brightgreen] Punk core navigation commands: " + + #todo - load from source code annotation? + set cmdinfo [list] + lappend cmdinfo [list help "?topics?" "This help. To see available subitems type: help topics"] + lappend cmdinfo [list i "cmd ?subcommand...?" "Show usage for a command or ensemble subcommand"] + lappend cmdinfo [list ./ "?subdir?" "view/change directory"] + lappend cmdinfo [list ../ "" "go up one directory"] + lappend cmdinfo [list ./new "subdir" "make new directory and switch to it"] + lappend cmdinfo [list n/ "?glob...?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match comands at any level )"] + lappend cmdinfo [list n// "" "view/change namespace (with command listing)"] + lappend cmdinfo [list "nn/" "" "go up one namespace"] + lappend cmdinfo [list "n/new" "" "make child namespace and switch to it"] + lappend cmdinfo [list dev "?subcommand?" "(ensemble command to make new projects/modules and to generate docs)"] + lappend cmdinfo [list a? "?subcommand...?" "view ANSI colours\n e.g a? web"] + + #set cmds [lsearch -all -inline -index 0 -subindices $cmdinfo *] + #set descr [lsearch -all -inline -index 1 -subindices $cmdinfo *] + #set widest1 [tcl::mathfunc::max {*}[lmap v $cmds {string length $v}]] + #set widest2 [tcl::mathfunc::max {*}[lmap v $descr {string length $v}]] + set t [textblock::class::table new -show_seps 0] + #foreach c $cmds d $descr { + # $t add_row [list $c $d] + #} + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + + + set warningblock "" + set introblock $mascotblock + append introblock \n $text + + #if {[catch {package require textblock} errM]} { + # append warningblock \n "WARNING: textblock package couldn't be loaded. Side-by-side display not available" + #} else { + # set introblock [textblock::join -- " " \n$mascotblock " " $text] + #} + + + lappend chunks [list stdout $introblock] + + + if {$topic in [list tcl]} { + if {[punk::lib::check::has_tclbug_script_var]} { + append warningblock \n "minor warning: punk::lib::check::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" + } + if {[punk::lib::check::has_tclbug_safeinterp_compile]} { + set indent " " + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_safeinterp returned true!" \n + append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/1095bf7f75]" + append warningblock [a] + } + if {[punk::lib::check::has_tclbug_lsearch_strideallinline]} { + set indent " " + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_lsearch_strideallinline returned true!" \n + append warningblock "${indent}(lsearch using -stride -all -inline -subindices does not return values corresponding to subindex when a single -index value is used)" \n + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/5a1aaa201d]" + append warningblock [a] + } + if {[punk::lib::check::has_tclbug_list_quoting_emptyjoin]} { + set indent " " + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_list_quoting returned true!" \n + append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/e38dce74e2]" + } + } + + set text "" + if {$topic in [list env environment]} { + #todo - move to punk::config? + upvar ::punk::config::punk_env_vars_config punkenv_config + upvar ::punk::config::other_env_vars_config otherenv_config + + set known_punk [dict keys $punkenv_config] + set known_other [dict keys $otherenv_config] + append text \n + set usetable 1 + if {$usetable} { + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + if {"windows" eq $::tcl_platform(platform)} { + #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. + #The Tcl ::env array is linked to the underlying process view of the environment + #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. + #an 'array get' will resynchronise. + #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. + array get ::env + } + #do an array read on ::env + foreach {v vinfo} $punkenv_config { + if {[info exists ::env($v)]} { + set c2 [set ::env($v)] + } else { + set c2 "(NOT SET)" + } + set help "" + if {[dict exists $vinfo help]} { + set help [dict get $vinfo help] + } + $t add_row [list $v $c2 $help] + } + $t configure_column 0 -headers [list "Punk environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set punktable [$t print] + $t destroy + + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + foreach {v vinfo} $otherenv_config { + if {[info exists ::env($v)]} { + set c2 [set ::env($v)] + } else { + set c2 "(NOT SET)" + } + $t add_row [list $v $c2] + } + $t configure_column 0 -headers [list "Other environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set othertable [$t print] + $t destroy + append text [textblock::join -- $punktable " " $othertable]\n + } else { + + append text $linesep\n + append text "punk environment vars:\n" + append text $linesep\n + set col1 [string repeat " " 25] + set col2 [string repeat " " 50] + foreach v $known_punk { + set c1 [overtype::left $col1 $v] + if {[info exists ::env($v)]} { + set c2 [overtype::left $col2 [set ::env($v)] + } else { + set c2 [overtype::right $col2 "(NOT SET)"] + } + append text "$c1 $c2\n" + } + append text $linesep\n + } + + lappend chunks [list stdout $text] + } + + if {$topic in [list console terminal]} { + set indent [string repeat " " [string length "WARNING: "]] + lappend cstring_tests [dict create\ + type "PM "\ + msg "PRIVACY MESSAGE"\ + f7 punk::ansi::controlstring_PM\ + f7desc "7bit ESC ^"\ + f8 punk::ansi::controlstring_PM8\ + f8desc "8bit \\x9e"\ + ] + lappend cstring_tests [dict create\ + type SOS\ + msg "STRING"\ + f7 punk::ansi::controlstring_SOS\ + f7desc "7bit ESC X"\ + f8 punk::ansi::controlstring_SOS8\ + f8desc "8bit \\x98"\ + ] + lappend cstring_tests [dict create\ + type APC\ + msg "APPLICATION PROGRAM COMMAND"\ + f7 punk::ansi::controlstring_APC\ + f7desc "7bit ESC _"\ + f8 punk::ansi::controlstring_APC8\ + f8desc "8bit \\x9f"\ + ] + + foreach test $cstring_tests { + set m [[dict get $test f7] [dict get $test msg]] + set hidden_width_m [punk::console::test_char_width $m] + set m8 [[dict get $test f8] [dict get $test msg]] + set hidden_width_m8 [punk::console::test_char_width $m8] + if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { + if {$hidden_width_m == 0} { + set d "[a+ green bold][dict get $test f7desc] [a red]${m}[a]" + } else { + set d "[a+ yellow bold][dict get $test f7desc] [a red]$m[a]" + } + if {$hidden_width_m8 == 0} { + set d8 "[a+ green ][dict get $test f8desc] [a red]$m8[a]" + } else { + set d8 "[a+ yellow bold][dict get $test f8desc] [a red]$m8[a]" + } + append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" + } + } + if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." + append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." + append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" + append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" + append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + } + } else { + append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" + } + + if {![catch {punk::console::check::has_bug_zwsp} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." + append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + } + } else { + append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" + } + + + set grapheme_support [punk::console::grapheme_cluster_support] + #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { + append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." + if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { + append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" + } + } else { + if {![dict get $grapheme_support available]} { + switch -- [dict get $grapheme_support mode] { + "unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." + } + "permanently_unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." + } + "BAD_RESPONSE" { + append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + } + } + } + } + + } + + lappend chunks [list stderr $warningblock] + if {$topic in [list topics help]} { + set text "" + set topics [dict create\ + "topics|help" "List help topics"\ + "tcl" "Tcl version warnings"\ + "env|environment" "punkshell environment vars"\ + "console|terminal" "Some console behaviour tests and warnings"\ + ] + + set t [textblock::class::table new -show_seps 0] + $t add_column -headers [list "Topic"] + $t add_column + foreach {k v} $topics { + $t add_row [list $k $v] + } + set widest0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$widest0 + 4}] + append text \n[$t print] + + lappend chunks [list stdout $text] + } + + return $chunks + } + proc help {args} { + set chunks [help_chunks {*}$args] + foreach chunk $chunks { + lassign $chunk chan text + puts -nonewline $chan $text + } + } + proc mode {{raw_or_line query}} { + package require punk::console + tailcall ::punk::console::mode $raw_or_line + } + + #this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it. + interp alias {} mode {} punk::mode + + proc aliases {{glob *}} { + tailcall punk::lib::aliases $glob + } + proc alias {{aliasorglob ""} args} { + tailcall punk::lib::alias $aliasorglob {*}$args + } + + + #pipeline-toys - put in lib/scriptlib? + ##geometric mean + #alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| + + + + + + #interp alias {} c {} clear ;#external executable 'clear' may not always be available + #todo - review + interp alias {} clear {} ::punk::reset + interp alias {} c {} ::punk::reset + proc reset {} { + if {[llength [info commands ::punk::repl::reset_terminal]]} { + #punk::repl::reset_terminal notifies prompt system of reset + punk::repl::reset_terminal + } else { + puts -nonewline stdout [punk::ansi::reset] + } + } + + + + #fileutil::cat except with checking for windows illegal path names (when on windows platform) + interp alias {} fcat {} punk::mix::util::fcat + + #---------------------------------------------- + interp alias {} linelistraw {} punk::linelistraw + + # 'path' collides with kettle path in kettle::doc function - todo - patch kettle? + interp alias {} PATH {} punk::path + + interp alias {} path_list {} punk::path_list + interp alias {} list_filter_cond {} punk::list_filter_cond + + + interp alias {} inspect {} punk::inspect + interp alias {} ooinspect {} punk::ooinspect + + interp alias {} linedict {} punk::linedict + interp alias {} dictline {} punk::dictline + + #todo - pipepure - evaluate pipeline in a slave interp without commands that have side-effects. (safe interp?) + interp alias {} % {} punk::% + interp alias {} pipeswitch {} punk::pipeswitch + interp alias {} pipeswitchc {} punk::pipeswitchc ;#closure version - more correct + interp alias {} pipecase {} punk::pipecase + interp alias {} pipematch {} punk::pipematch + interp alias {} ispipematch {} punk::ispipematch + interp alias {} pipenomatchvar {} punk::pipenomatchvar + interp alias {} pipedata {} punk::pipedata + interp alias {} pipeset {} punk::pipeset + interp alias {} pipealias {} punk::pipealias + interp alias {} listset {} punk::listset ;#identical to pipeset + + + #non-core aliases + interp alias {} is_list_all_in_list {} punk::lib::is_list_all_in_list + interp alias {} is_list_all_ni_list {} punk::libis_list_all_ni_list + + + + #interp alias {} = {} ::punk::pipeline = "" "" + #interp alias {} = {} ::punk::match_assign "" "" + interp alias {} .= {} ::punk::pipeline .= "" "" + #proc .= {args} { + # #uplevel 1 [list ::punk::pipeline .= "" "" {*}$args] + # tailcall ::punk::pipeline .= "" "" {*}$args + #} + + + interp alias {} rep {} ::tcl::unsupported::representation + interp alias {} dis {} ::tcl::unsupported::disassemble + + + + # ls aliases - note that tcl doesn't exand * but sh_xxx functions pass to sh -c allowing shell expansion + interp alias {} l {} sh_runout -n ls -A ;#plain text listing + #interp alias {} ls {} sh_runout -n ls -AF --color=always + interp alias {} ls {} shellrun::runconsole ls -AF --color=always ;#use unknown to use terminal and allow | more | less + #note that shell globbing with * won't work on unix systems when using unknown/exec + interp alias {} lw {} sh_runout -n ls -AFC --color=always ;#wide listing (use A becaus no extra info on . & ..) + interp alias {} ll {} sh_runout -n ls -laFo --color=always ;#use a instead of A to see perms/owner of . & .. + # -v for natural number sorting not supported on freeBSD. Todo - test at startup and modify aliases? + #interp alias {} lw {} ls -aFv --color=always + + interp alias {} dir {} shellrun::runconsole dir + + # punk::nav::fs + package require punk::nav::fs + interp alias {} ./ {} punk::nav::fs::d/ + interp alias {} ../ {} punk::nav::fs::dd/ + interp alias {} d/ {} punk::nav::fs::d/ + interp alias {} dd/ {} punk::nav::fs::dd/ + + interp alias {} vwd {} punk::nav::fs::vwd ;#return punk::nav::fs::VIRTUAL_CWD - and report to stderr pwd if different + interp alias {} dirlist {} punk::nav::fs::dirlist + interp alias {} dirfiles {} punk::nav::fs::dirfiles + interp alias {} dirfiles_dict {} punk::nav::fs::dirfiles_dict + + interp alias {} ./new {} punk::nav::fs::d/new + interp alias {} d/new {} punk::nav::fs::d/new + interp alias {} ./~ {} punk::nav::fs::d/~ + interp alias {} d/~ {} punk::nav::fs::d/~ + interp alias "" x/ "" punk::nav::fs::x/ + + + if {$::tcl_platform(platform) eq "windows"} { + set has_powershell 1 + interp alias {} dl {} dir /q + interp alias {} dw {} dir /W/D + } else { + #todo - natsorted equivalent + #interp alias {} dl {} + interp alias {} dl {} puts stderr "not implemented" + interp alias {} dw {} puts stderr "not implemented" + #todo - powershell detection on other platforms + set has_powershell 0 + } + if {$has_powershell} { + #see also powershell runspaces etc: + # powershell runspaces e.g $rs=[RunspaceFactory]::CreateRunspace() + # $ps = [Powershell]::Create() + + interp alias {} ps {} exec >@stdout pwsh -nolo -nop -c + interp alias {} psx {} runx -n pwsh -nop -nolo -c + interp alias {} psr {} run -n pwsh -nop -nolo -c + interp alias {} psout {} runout -n pwsh -nop -nolo -c + interp alias {} pserr {} runerr -n pwsh -nop -nolo -c + interp alias {} psls {} shellrun::runconsole pwsh -nop -nolo -c ls + interp alias {} psps {} shellrun::runconsole pwsh -nop -nolo -c ps + } else { + set ps_missing "powershell missing (powershell is open source and can be installed on windows and most unix-like platforms)" + interp alias {} ps {} puts stderr $ps_missing + interp alias {} psx {} puts stderr $ps_missing + interp alias {} psr {} puts stderr $ps_missing + interp alias {} psout {} puts stderr $ps_missing + interp alias {} pserr {} puts stderr $ps_missing + interp alias {} psls {} puts stderr $ps_missing + interp alias {} psps {} puts stderr $ps_missing + } + proc psencode {cmdline} { + + } + proc psdecode {encodedcmd} { + + } + + proc repl {startstop} { + switch -- $startstop { + stop { + if {[punk::repl::codethread::is_running]} { + puts stdout "Attempting repl stop. Try ctrl-c or exit command to leave interpreter" + set ::repl::done 1 + } + } + start { + if {[punk::repl::codethread::is_running]} { + repl::start stdin + } + } + default { + error "repl unknown action '$startstop' - must be start or stop" + } + } + } + +} + + +# -- --- --- --- +#Load decks. commandset packages are not loaded until the deck is called. +# -- --- --- --- +package require punk::mod +#punk::mod::cli set_alias pmod +punk::mod::cli set_alias app + +#todo - change to punk::dev +package require punk::mix +punk::mix::cli set_alias dev +punk::mix::cli set_alias deck ;#deprecate! + +#todo - add punk::deck for managing cli modules and commandsets + +package require punkcheck::cli +punkcheck::cli set_alias pcheck +punkcheck::cli set_alias punkcheck +# -- --- --- --- + +package provide punk [namespace eval punk { + #FUNCTL + variable version + set version 0.1 +}] + + + diff --git a/src/project_layouts/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 new file mode 100644 index 00000000..5b45b2bc --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -0,0 +1,290 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::aliascore 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::aliascore 0 0.1.0] +#[copyright "2024"] +#[titledesc {punkshell command aliases}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::aliascore] +#[keywords module alias] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::aliascore +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::aliascore +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::aliascore::class { +# #*** !doctools +# #[subsection {Namespace punk::aliascore::class}] +# #[para] class definitions +# if {[info commands [namespace current]::interface_sample1] eq ""} { +# #*** !doctools +# #[list_begin enumerated] +# +# # oo::class create interface_sample1 { +# # #*** !doctools +# # #[enum] CLASS [class interface_sample1] +# # #[list_begin definitions] +# +# # method test {arg1} { +# # #*** !doctools +# # #[call class::interface_sample1 [method test] [arg arg1]] +# # #[para] test method +# # puts "test: $arg1" +# # } +# +# # #*** !doctools +# # #[list_end] [comment {-- end definitions interface_sample1}] +# # } +# +# #*** !doctools +# #[list_end] [comment {--- end class enumeration ---}] +# } +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::aliascore { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable aliases + #use absolute ns ie must be prefixed with :: + #single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased + + #functions must be in export list of their source namespace + set aliases [tcl::dict::create\ + val ::punk::pipe::val\ + aliases ::punk::lib::aliases\ + alias ::punk::lib::alias\ + tstr ::punk::lib::tstr\ + list_as_lines ::punk::lib::list_as_lines\ + lines_as_list ::punk::lib::lines_as_list\ + linelist ::punk::lib::linelist\ + linesort ::punk::lib::linesort\ + pdict ::punk::lib::pdict\ + plist {::punk::lib::pdict -roottype list}\ + showlist {::punk::lib::showdict -roottype list}\ + 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\ + a? ::punk::console::code_a?\ + A? {::punk::console::code_a? forcecolor}\ + a+ ::punk::console::code_a+\ + A+ {::punk::console::code_a+ forcecolour}\ + a ::punk::console::code_a\ + A {::punk::console::code_a forcecolour}\ + smcup ::punk::console::enable_alt_screen\ + rmcup ::punk::console::disable_alt_screen\ + ] + + #*** !doctools + #[subsection {Namespace punk::aliascore}] + #[para] Core API functions for punk::aliascore + #[list_begin definitions] + + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + #todo - options as to whether we should raise an error if collisions found, undo aliases etc? + proc init {args} { + set defaults {-force 0} + set opts [dict merge $defaults $args] + set opt_force [dict get $opts -force] + + #we never override existing aliases to ::repl::interp* even if -force = 1 + #(these are our safebase aliases) + set ignore_pattern "::repl::interp*" + set ignore_aliases [list] + + variable aliases + set existing [list] + set conflicts [list] + foreach {a cmd} $aliases { + if {[tcl::info::commands ::$a] ne ""} { + lappend existing $a + set existing_alias [interp alias "" $a] + if {$existing_alias ne ""} { + set existing_target $existing_alias + if {[string match $ignore_pattern $existing_target]} { + #don't consider it a conflict - will use ignore_aliases to exclude it below + lappend ignore_aliases $a + continue + } + } else { + if {[catch {tcl::namespace::origin $a} existing_command]} { + set existing_command "" + } + set existing_target $existing_command + } + + if {$existing_target ne $cmd} { + #command exists in global ns but doesn't match our defined aliases/imports + lappend conflicts $a + } + } + } + if {!$opt_force && [llength $conflicts]} { + error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" + } + + set tempns ::temp_[info cmdcount] ;#temp ns for renames + dict for {a cmd} $aliases { + #puts "aliascore $a -> $cmd" + if {$a in $ignore_aliases} { + continue + } + if {[llength $cmd] > 1} { + interp alias {} $a {} {*}$cmd + } else { + if {[tcl::info::commands $cmd] ne ""} { + #todo - ensure exported? noclobber? + if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { + #puts stderr "importing $cmd" + tcl::namespace::eval :: [list namespace import $cmd] + } 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} + } + } else { + interp alias {} $a {} {*}$cmd + } + } + } + #tcl::namespace::delete $tempns + return [dict create aliases [dict keys $aliases] unchanged $ignore_aliases changed $conflicts] + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::aliascore ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#interp alias {} list_as_lines {} punk::lib::list_as_lines +#interp alias {} lines_as_list {} punk::lib::lines_as_list +#interp alias {} ansistrip {} punk::ansi::ansistrip ;#review +#interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features +#interp alias {} linesort {} punk::lib::linesort + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::aliascore::lib { + namespace export {[a-z]*} ;# Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace punk::aliascore::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::aliascore::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval punk::aliascore::system { + #*** !doctools + #[subsection {Namespace punk::aliascore::system}] + #[para] Internal functions that are not part of the API + + + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::aliascore [namespace eval punk::aliascore { + variable pkg punk::aliascore + variable version + set version 0.1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/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 85cb9f27..9b8c7619 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 @@ -19,21 +19,21 @@ #[manpage_begin punkshell_module_punk::ansi 0 0.1.1] #[copyright "2023"] #[titledesc {Ansi string functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] +#[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] #[require punk::ansi] #[keywords module ansi terminal console string] #[description] -#[para]Ansi based terminal control string functions -#[para]See [package punk::ansi::console] for related functions for controlling a console +#[para]Ansi based terminal control string functions +#[para]See [package punk::ansi::console] for related functions for controlling a console # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Overview] -#[para] overview of punk::ansi +#[para] overview of punk::ansi #[para]punk::ansi functions return their values - no implicit emission to console/stdout #[subsection Concepts] -#[para]Ansi codes can be used to control most terminals on most platforms in an 'almost' standard manner +#[para]Ansi codes can be used to control most terminals on most platforms in an 'almost' standard manner #[para]There are many differences in terminal implementations - but most should support a core set of features #[para]punk::ansi does not contain any code for direct terminal manipulation via the local system APIs. #[para]Sticking to ansi codes where possible may be better for cross-platform and remote operation where such APIs are unlikely to be useable. @@ -45,7 +45,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::ansi +#[para] packages used by punk::ansi #[list_begin itemized] package require Tcl 8.6- @@ -72,7 +72,7 @@ tcl::namespace::eval punk::ansi::class { if {![llength [tcl::info::commands class_ansi]]} { oo::class create class_ansi { - variable o_ansistringobj + variable o_ansistringobj variable o_render_dimensions ;#last dimensions at which we rendered variable o_rendered @@ -83,7 +83,7 @@ tcl::namespace::eval punk::ansi::class { } #a straight string compare may be faster.. but a checksum is much smaller in memory, so we'll use that by default. - set o_rendered_what "" + set o_rendered_what "" #There may also be advantages to renering to a class_ansistring class object set o_render_dimensions $dimensions @@ -100,18 +100,18 @@ tcl::namespace::eval punk::ansi::class { error "class_ansi::render dimensions must be of the form x" } set cksum "not-done" - if {$dimensions ne $o_render_dimensions || $o_rendered_what ne [set cksum [$o_ansistringobj checksum]]} { + if {$dimensions ne $o_render_dimensions || $o_rendered_what ne [set cksum [$o_ansistringobj checksum]]} { #some ansi layout/art relies on wrapping at the width-dimension to display properly #this includes cursor movements ie right arrow can move cursor to columns in lines below #overflow is a different concept - perhaps not particularly congruent with the idea of the textblock as a mini terminal emulator. #overflow effectively auto-expands the block(terminal?) width #overflow and wrap both being true won't make sense unless we implement a max_overflow concept - set o_rendered [overtype::renderspace -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set o_rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] if {$cksum eq "not-done"} { #if dimensions changed - the checksum won't have been done set o_rendered_what [$o_ansistringobj checksum] } else { - set o_rendered_what $cksum + set o_rendered_what $cksum } set o_render_dimensions $dimensions } @@ -127,19 +127,34 @@ tcl::namespace::eval punk::ansi::class { error "class_ansi::render dimensions must be of the form x" } set o_dimensions $dimensions - - - set rendered [overtype::renderspace -experimental {test_mode} -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + + + set rendered [overtype::renderspace -cp437 1 -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } + + lappend ::punk::ansi::class::PUNKARGS [list { + @id -id "::punk::ansi::class::class_ansi render_to_input_line" + @cmd -name "punk::ansi::class::class_ansi render_to_input_line" -help\ + "render string from line 0 to line + (experimental/debug)" + -dimensions -type string -help\ + "WxH where W is integer width >= 1 and H is integer heigth >= 1" + -minus -type integer -help\ + "number of chars to exclude from end" + @values -min 1 -max 1 + line -type indexexpression + }] method render_to_input_line {args} { if {[llength $args] < 1} { puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } set x [lindex $args end] set arglist [lrange $args 0 end-1] if {[llength $arglist] %2 != 0} { puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } set opts [tcl::dict::create\ -dimensions 80x24\ @@ -152,6 +167,7 @@ tcl::namespace::eval punk::ansi::class { } default { puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x" + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } } } @@ -169,14 +185,14 @@ tcl::namespace::eval punk::ansi::class { set lfvis [ansistring VIEW -lf 1 \n] set maplf [list \n "[a+ green bold reverse]${lfvis}[a]\n"] ;#a mapping to highlight newlines - set lines [split [$o_ansistringobj get] \n] + set lines [split [$o_ansistringobj get] \n] set rlines [lrange $lines 0 $x] - set chunk [::join $rlines \n] + set chunk [::join $rlines \n] append chunk \n if {$opt_minus ne "0"} { - set chunk [tcl::string::range $chunk 0 end-$opt_minus] + set chunk [tcl::string::range $chunk 0 end-$opt_minus] } - set rendered [overtype::renderspace -experimental {test_mode} -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] + set rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] set marker "" for {set i 1} {$i <= $w} {incr i} { if {$i % 10 == 0} { @@ -196,7 +212,7 @@ tcl::namespace::eval punk::ansi::class { set chunk [ansistring VIEWSTYLE $chunk] set chunk [tcl::string::map $maplf $chunk] - #keep chunkdisplay narrower - leave at 80 or it will get unwieldy for larger image widths + #keep chunkdisplay narrower - leave at 80 or it will get unwieldy for larger image widths set chunkdisplay [overtype::renderspace -wrap 1 -width 80 -height 1 "" $chunk] set renderheight [llength [split $rendered \n]] set chunkdisplay_lines [split $chunkdisplay \n] @@ -205,7 +221,7 @@ tcl::namespace::eval punk::ansi::class { #the input chunk lines are often much longer than the output.. resulting in main content being way up the screen. It's often impractical to view more than the tail of the chunkdisplay. textblock::join -- $rendered $chunkdisplay_block } - + method checksum {} { return [$o_ansistringobj checksum] } @@ -221,7 +237,7 @@ tcl::namespace::eval punk::ansi::class { -lf 0\ -vt 0\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -251,7 +267,7 @@ tcl::namespace::eval punk::ansi::class { method viewchars {args} { set defaults [list\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -279,7 +295,7 @@ tcl::namespace::eval punk::ansi::class { method viewstyle {args} { set defaults [list\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -322,19 +338,20 @@ tcl::namespace::eval punk::ansi::class { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::ansi { + variable PUNKARGS #*** !doctools #[subsection {Namespace punk::ansi}] - #[para] Core API functions for punk::ansi + #[para] Core API functions for punk::ansi #[list_begin definitions] - #old-school ansi graphics - C0 control glyphs. - variable cp437_map + #old-school ansi graphics - C0 control glyphs. + variable cp437_map #for cp437 images we need to map these *after* splitting ansi, to single-width unicode chars #It would also probably be problematic to map \u000A to the glyph - as this is the newline - it included in the map anyway for completeness. The caller may have to manually carve that or other specific c0 controls out of the map to use it depending on the situation(?) #Layout for cp437 won't be right if you don't at least set width of control-chars to 1 - but also some images specifically use these glyphs - #most fonts don't seem to supply graphics for these control characters even when cp437 is in use - the c1 control glyphs appear to be more widely available - but we could add them here too + #most fonts don't seem to supply graphics for these control characters even when cp437 is in use - the c1 control glyphs appear to be more widely available - but we could add them here too #by mapping these we can display regardless. - #nul char - no cp437 image but commonly used as space in ansi graphics. + #nul char - no cp437 image but commonly used as space in ansi graphics. #(This is a potential conflict because we use nul as a filler to mean empty column in overtype rendering) REVIEW tcl::dict::set cp437_map \u0000 " " ;#space tcl::dict::set cp437_map \u0001 \u263A ;#smiley @@ -360,11 +377,11 @@ tcl::namespace::eval punk::ansi { tcl::dict::set cp437_map \u0015 \u00A7 ;#Section Sign tcl::dict::set cp437_map \u0016 \u25AC ;#Heavy horizontal? tcl::dict::set cp437_map \u0017 \u21A8 ;#updown arrow 2 ? - tcl::dict::set cp437_map \u0018 \u2191 ;#up arrow - tcl::dict::set cp437_map \u0019 \u2193 ;#down arrow - tcl::dict::set cp437_map \u001A \u2192 ;#right arrow - tcl::dict::set cp437_map \u001B \u2190 ;#left arrow - tcl::dict::set cp437_map \u001C \u221F ;#bottom left corner + tcl::dict::set cp437_map \u0018 \u2191 ;#up arrow + tcl::dict::set cp437_map \u0019 \u2193 ;#down arrow + tcl::dict::set cp437_map \u001A \u2192 ;#right arrow + tcl::dict::set cp437_map \u001B \u2190 ;#left arrow + tcl::dict::set cp437_map \u001C \u221F ;#bottom left corner tcl::dict::set cp437_map \u001D \u2194 ;#left-right arrow tcl::dict::set cp437_map \u001E \u25B2 ;#up arrow triangle tcl::dict::set cp437_map \u001F \u25BC ;#down arrow triangle @@ -379,7 +396,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics c \u240c ;#symbol for FF tcl::dict::set map_special_graphics d \u240d ;#symbol for CR tcl::dict::set map_special_graphics e \u240a ;#symbol for LF - tcl::dict::set map_special_graphics f \u00b0 ;#degree sign + tcl::dict::set map_special_graphics f \u00b0 ;#degree sign tcl::dict::set map_special_graphics g \u00b1 ;#plus-minus sign tcl::dict::set map_special_graphics h \u2424 ;#symbol for NL tcl::dict::set map_special_graphics i \u240b ;#symbol for VT @@ -391,8 +408,8 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics o \u23ba ;#horizontal scan line-1 tcl::dict::set map_special_graphics p \u23bb ;#horizontal scan line-3 tcl::dict::set map_special_graphics q \u2500 ;#light horizontal - box drawing - tcl::dict::set map_special_graphics r \u23bc ;#horizontal scan line-7 - tcl::dict::set map_special_graphics s \u23bd ;#horizontal scan line-9 + tcl::dict::set map_special_graphics r \u23bc ;#horizontal scan line-7 + tcl::dict::set map_special_graphics s \u23bd ;#horizontal scan line-9 tcl::dict::set map_special_graphics t \u251c ;#light vertical and right - box drawing tcl::dict::set map_special_graphics u \u2524 ;#light vertical and left - box drawing tcl::dict::set map_special_graphics v \u2534 ;#light up and horizontal - box drawing @@ -402,10 +419,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics z \u2265 ;#greater than or equal tcl::dict::set map_special_graphics "\{" \u03c0 ;#greek small letter pi tcl::dict::set map_special_graphics "|" \u2260 ;#not equal to - tcl::dict::set map_special_graphics "\}" \u00a3 ;#pound sign + tcl::dict::set map_special_graphics "\}" \u00a3 ;#pound sign tcl::dict::set map_special_graphics ~ \u00b7 ;#middle dot - #see also ansicolour page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control + #see also ansicolour page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control variable test "blah\033\[1;33mETC\033\[0;mOK" @@ -413,11 +430,17 @@ tcl::namespace::eval punk::ansi { tcl::namespace::export\ {a?} {a+} a \ ansistring\ + ansiwrap\ convert*\ clear*\ cursor_*\ + delete*\ detect*\ + erase*\ get_*\ + hyperlink\ + hyperlink_open\ + hyperlink_close\ move*\ reset*\ ansistrip*\ @@ -428,14 +451,14 @@ tcl::namespace::eval punk::ansi { variable escape_terminals #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] - #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - tcl::dict::set escape_terminals OSC [list \007 \033\\ \u009c] ;#note mix of 1 and 2-byte terminals + #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic + tcl::dict::set escape_terminals OSC [list \007 \033\\ \u009c] ;#note mix of 1 and 2-byte terminals tcl::dict::set escape_terminals DCS [list \007 \033\\ \u009c] tcl::dict::set escape_terminals MISC [list \007 \033\\ \u009c] - #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) + #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) #This using a different type of ST to that of the opening sequence is presumably unlikely in the wild - but who knows? - #review - there doesn't seem to be an \x1b#7 + #review - there doesn't seem to be an \x1b#7 # https://espterm.github.io/docs/VT100%20escape%20codes.html #self-contained 2 byte ansi escape sequences - review more? @@ -456,9 +479,9 @@ tcl::namespace::eval punk::ansi { #comparitive test (performance) string-append vs 2-object (with existing splits) append proc test_cat1 {ansi1 ansi2} { #make sure objects have splits - set s1 [ansistring NEW $ansi1] + set s1 [ansistring NEW $ansi1] tcl::namespace::eval [info object namespace $s1] {my MakeSplit} - set s2 [ansistring NEW $ansi2] + set s2 [ansistring NEW $ansi2] tcl::namespace::eval [info object namespace $s2] {my MakeSplit} #operation under test @@ -469,13 +492,13 @@ tcl::namespace::eval punk::ansi { $s2 destroy #$s1 append \033\[31mX ;#redX - return $s1 + return $s1 } proc test_cat2 {ansi1 ansi2} { #make sure objects have splits - set s1 [ansistring NEW $ansi1] + set s1 [ansistring NEW $ansi1] tcl::namespace::eval [info object namespace $s1] {my MakeSplit} - set s2 [ansistring NEW $ansi2] + set s2 [ansistring NEW $ansi2] tcl::namespace::eval [info object namespace $s2] {my MakeSplit} #operation under test @@ -490,12 +513,12 @@ tcl::namespace::eval punk::ansi { # -------------------------------------- - #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? + #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? #In testing old ansi graphics files available on the web, some files need encoding {utf-8 cp437} some just cp437 proc readfile {fname {encoding cp437}} { - #todo + #todo #1- look for BOM - read according to format given by BOM - #2- assume utf-8 + #2- assume utf-8 #3- if errors - assume cp437? if {[llength $encoding] == 1} { @@ -514,11 +537,8 @@ tcl::namespace::eval punk::ansi { set encnames [encoding names] set encoding "" set dimensions "" - set test_mode 0 foreach a $args { - if {$a eq "test_mode"} { - set test_mode 1 - } elseif {$a in $encnames} { + if {$a in $encnames} { set encoding $a } else { if {[regexp {[0-9]+(?:x|X)[0-9]+} $a]} { @@ -553,59 +573,158 @@ tcl::namespace::eval punk::ansi { $obj destroy return $result } - proc example {} { - #todo - review dependency on punk::repo ? + + proc Get_ansifolder {} { + if {[catch {punk::repo::find_project} base]} { + set base "" + } + if {$base eq ""} { + #pwd not avail in safe interp + if {![catch {pwd} CWD]} { + set base $CWD + } + } + if {[info commands file] eq ""} { + #probably a safe interp + return "UNAVAILABLE" + } + return [file join $base src/testansi] + } + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::ansi::example + @cmd -name punk::ansi::example -help "Display .ans image files in a grid that will fit in console + " + -colwidth -default 82 -help\ + "Width of each column - default of 82 will fit a standard 80wide ansi image + (when framed) + You can specify a narrower width to truncate images on the right side" + -folder -default "${[punk::ansi::Get_ansifolder]}" -help\ + "Base folder for files if relative paths are used. + Defaults to /src/testansi - where projectbase is determined + from the current directory. + " + @values -min 0 -max -1 + files -default {belinda.ans bot.ans flower.ans fish.ans} -multiple true -help\ + "List of filenames - leave empty to display 4 defaults" + } ""] + + proc example {args} { + set argd [punk::args::get_by_id ::punk::ansi::example $args] + set colwidth [dict get $argd opts -colwidth] + if {[info commands file] eq ""} { + error "file command unavailable - punk::ansi::example cannot be shown" + } + set ansifolder [file normalize [dict get $argd opts -folder]] + set fnames [dict get $argd values files] + + #assumes fixed column widths e.g 80col images will fit in 82-width frames (common standard for old ansi art) (of arbitrary height) + #todo - review dependency on punk::repo ? package require textblock package require punk::repo package require punk::console - set fnames [list belinda.ans bot.ans flower.ans fish.ans] - set base [punk::repo::find_project] - set ansibase [file join $base src/testansi] - if {![file exists $ansibase]} { - puts stderr "Missing testansi folder at $base/src/testansi" + if {![file exists $ansifolder]} { + puts stderr "Missing folder at $ansifolder" puts stderr "Ensure ansi test files exist: $fnames" #error "punk::ansi::example Cannot find example files" } - set missingbase [a+ yellow][textblock::block 80 23 ?][a] + set termsize [punk::console:::get_size] + set termcols [dict get $termsize columns] + set margin 4 ;#review + set freewidth [expr {$termcols-$margin}] + if {$freewidth < $colwidth} { + puts stderr "[a+ red bold]punk::ansi::example freewidth: $freewidth < colwidth: $colwidth TRUNCATING IMAGES[a]" + set colwidth $freewidth + } + set per_row [expr {$freewidth / $colwidth}] + + set missingbase [a+ yellow][textblock::block [expr {$colwidth-2}] 23 ?][a] ;#assuming standard frame - subtract 2 for left/right borders set pics [list] foreach f $fnames { - if {![file exists $ansibase/$f]} { - set p [overtype::left $missingbase "[a+ red bold]\nMissing file\n$ansibase/$f[a]"] + if {[file pathtype $f] ne "absolute"} { + set filepath [file normalize $ansifolder/$f] + } else { + set filepath [file normalize $f] + } + if {![file exists $filepath]} { + set p [overtype::left $missingbase "[a+ red bold]\nMissing file\n$f[a]"] lappend pics [tcl::dict::create filename $f pic $p status missing] } else { - set img [join [lines_as_list -line trimline -block trimtail [ansicat $ansibase/$f]] \n] - lappend pics [tcl::dict::create filename $f pic $img status ok] + #set img [join [lines_as_list -line trimline -block trimtail [ansicat $filepath]] \n] + #-line trimline will wreck some images + set img [join [lines_as_list -block trimtail [ansicat $filepath]] \n] + lappend pics [tcl::dict::create filename $f pic $img status ok] } } - set termsize [punk::console:::get_size] - set margin 4 - set freewidth [expr {[tcl::dict::get $termsize columns]-$margin}] - set per_row [expr {$freewidth / 80}] - set rowlist [list] - set row [list] - set i 1 + set rowlist [list] ;# { { } { } } + set heightlist [list] ;# { { } { } } + set maxheights [list] ;# { } + set row [list] ;#wip row + set rowh [list] ;#wip row img heights + set i 1 ;#track image index of whole pics list + set rowindex 0 foreach picinfo $pics { set subtitle "" if {[tcl::dict::get $picinfo status] ne "ok"} { - set subtitle [tcl::dict::get $picinfo status] + set subtitle [tcl::dict::get $picinfo status] } set title [tcl::dict::get $picinfo filename] - lappend row [textblock::frame -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] + set fr [textblock::frame -checkargs 0 -width $colwidth -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] + # -- --- --- --- + #we need the max height of a row element to use join_basic instead of join below + # -- --- --- --- + set fr_height [textblock::height $fr] + lappend row $fr + lappend rowh $fr_height + + set rowmax [lindex $maxheights $rowindex] + if {$rowmax eq ""} { + #empty result means no maxheights entry for this row yet + set rowmax $fr_height + lappend maxheights $rowmax + } else { + if {$fr_height > $rowmax} { + set rowmax $fr_height + lset maxheights end $rowmax + } + } + # -- --- --- --- + if {$i % $per_row == 0} { lappend rowlist $row + lappend heightlist $rowh + incr rowindex set row [list] + set rowh [list] } elseif {$i == [llength $pics]} { lappend rowlist $row + lappend heightlist $rowh } incr i } - + #puts "--> maxheights: $maxheights" + #puts "--> heightlist: $heightlist" set result "" - foreach r $rowlist { - append result [textblock::join_basic -- {*}$r] \n + set rowindex 0 + set blankline [string repeat " " $colwidth] + foreach imgs $rowlist heights $heightlist { + set maxheight [lindex $maxheights $rowindex] + set adjusted_row [list] + foreach i $imgs h $heights { + if {$h < $maxheight} { + #add blank lines to bottom of shorter images so join_basic can be used. + #textblock::join of ragged-height images would work and remove the need for all the height calculation + #.. but it requires much more processing + append i [string repeat \n$blankline [expr {$maxheight - $h}]] + } + lappend adjusted_row $i + } + append result [textblock::join_basic -- {*}$adjusted_row] \n + incr rowindex } @@ -627,109 +746,44 @@ tcl::namespace::eval punk::ansi { #b) DEVICE CONTROL STRING (DCS) #c) OPERATING SYSTEM COMMAND (OSC) #d) PRIVACY MESSAGE (PM) - #e) START OF STRING (SOS) + #e) START OF STRING (SOS) # #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ - #The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out. + #The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out. #todo - review - printing_length calculations affected by whether terminal honours PMs or not. detect and accomodate. #review - can terminals handle SGR codes within a PM? #Wezterm will hide PM,SOS,APC - but not any part following an SGR code - i.e it seems to terminate hiding before the ST (apparently at the ) proc controlstring_PM {text} { - return "\x1b^${text}\033\\" + #dquotes with trailing \\ in string will confuse silly editors + return \x1b^${text}\033\\ } proc controlstring_PM8 {text} { - return "\x9e${text}\x9c" + return \x9e${text}\x9c } proc controlstring_SOS {text} { - return "\x1bX${text}\033\\" + return \x1bX${text}\033\\ } proc controlstring_SOS8 {text} { - return "\x98${text}\x9c" + return \x98${text}\x9c } proc controlstring_APC {text} { - return "\x1b_${text}\033\\" + return \x1b_${text}\033\\ } proc controlstring_APC8 {text} { - return "\x9f${text}\x9c" + return \x9f${text}\x9c } #there is also the SGR hide code (8) which has intermittent terminal support #This doesn't change the output length - so support is tricky to detec. (terminal checksum report?) #candidate for zig/c implementation? proc stripansi2 {text} { - - - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters join [::punk::ansi::ta::split_at_codes $text] "" } - proc stripansi1 {text} { - - #todo - character set selection - SS2 SS3 - how are they terminated? REVIEW - - variable escape_terminals ;#dict - variable ::punk::ansi::ta::standalone_code_map ;#map to empty string - - set text [convert_g0 $text] - - - set text [tcl::string::map $standalone_code_map $text] - #e.g standalone 2 byte and 3 byte VT100(?) sequences - some of these work in wezterm - #\x1b#3 double-height letters top half - #\x1b#4 double-height letters bottom half - #\x1b#5 single-width line - #\x1b#6 double-width line - #\x1b#8 dec test fill screen - - - #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. - - #Theoretically line endings can occur within an ST payload (review e.g title?) - #ecma standard says: The character string following may consist of any bit combination, except those representing SOS or STRING TERMINATOR (ST) - - set inputlist [split $text ""] - set outputlist [list] - - set in_escapesequence 0 - #assumption - text already 'rendered' - ie no cursor movement controls . (what about backspace and lone carriage returns - they are horizontal cursor movements) - - set i 0 - foreach u $inputlist { - set v [lindex $inputlist $i+1] - set uv ${u}${v} - if {$in_escapesequence eq "2b"} { - #2nd byte - done. - set in_escapesequence 0 - } elseif {$in_escapesequence != 0} { - set endseq [tcl::dict::get $escape_terminals $in_escapesequence] - if {$u in $endseq} { - set in_escapesequence 0 - } elseif {$uv in $endseq} { - set in_escapesequence 2b ;#flag next byte as last in sequence - } - } else { - #handle both 7-bit and 8-bit CSI and OSC - if {[regexp {^(?:\033\[|\u009b)} $uv]} { - set in_escapesequence CSI - } elseif {[regexp {^(?:\033\]|\u009d)} $uv]} { - set in_escapesequence OSC - } elseif {[regexp {^(?:\033P|\u0090)} $uv]} { - set in_escapesequence DCS - } elseif {[regexp {^(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)} $uv]} { - #SOS,PM,APC - all terminated with ST - set in_escapesequence MISC - } else { - lappend outputlist $u - } - } - incr i - } - return [join $outputlist ""] - } - #review - what happens when no terminator? #todo - map other character sets to unicode equivs? There seems to be little support for other than the DEC special graphics set.. ISO2022 character switching not widely supported - may be best considered deprecated(?) # convert esc(0 -> esc(B graphics sequences to single char unicode equivalents e.g box drawing set @@ -739,7 +793,7 @@ tcl::namespace::eval punk::ansi { #using not \033 inside to stop greediness - review how does it compare to ".*?" #variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - #set re {\033\(0[^\033]*\033\(B} + #set re {\033\(0[^\033]*\033\(B} #set re {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} #set re2 {\033\(0(.*)\033\(B} ;#capturing @@ -752,9 +806,9 @@ tcl::namespace::eval punk::ansi { #don't call detect_g0 in here. Leave for caller. e.g ansistrip uses detect_g0 to decide whether to call this. - set re_g0_open_or_close {\x1b\(0|\x1b\(B} + set re_g0_open_or_close {\x1b\(0|\x1b\(B} set parts [::punk::ansi::ta::_perlish_split $re_g0_open_or_close $text] - set out {} + set out {} set g0_on 0 foreach {other g} $parts { if {$g0_on} { @@ -784,7 +838,7 @@ tcl::namespace::eval punk::ansi { #That will either stop us matching - so no conversion - or risk converting parts of the ansi codes #using not \033 inside to stop greediness - review how does it compare to ".*?" #variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - set re {\033\(0[^\033]*\033\(B} + set re {\033\(0[^\033]*\033\(B} set re2 {\033\(0(.*)\033\(B} ;#capturing #box sample @@ -809,28 +863,97 @@ tcl::namespace::eval punk::ansi { return $out } + + #Wrap text in ansi codes to switch to DEC alternate graphics character set. + #todo vt52 versions proc g0 {text} { return \x1b(0$text\x1b(B } + variable altg_map [dict create\ + hl q\ + vl x\ + tlc l\ + trc k\ + blc m\ + ltj t\ + rtj u\ + ttj w\ + btj v\ + rtj u\ + fwj n\ + ] + proc altg_map {names} { + variable altg_map + set result [list] + foreach nm $names { + if {[dict exists $altg_map $nm]} { + lappend result [dict get $altg_map $nm] + } else { + lappend "" + } + } + return $result + } + + # -------------------------------- + # Taken from term::ansi::code::ctrl + # -------------------------------- + #Note that SYN (\016) seems to put terminals in a state + #where alternate graphics are not processed. + #an ETB (\017) needs to be sent to get alt graphics working again. + #It isn't known what software utilises SYN/ETB within altg sequences + # (presumably to alternate between the charsets within a graphics-on/graphics-off section) + #but as modern emulators seem to react to it, we should handle it. + #REVIEW - this mapping not fully understood + #used by groptim + variable grforw + variable grback + variable _ + + foreach _ { + ! \" # $ % & ' ( ) * + , - . / + 0 1 2 3 4 5 6 7 8 9 : ; < = > + ? @ A B C D E F G H I J K L M + N O P Q R S T U V W X Y Z [ ^ + \\ ] + } { + lappend grforw \016$_ $_\016 + lappend grback $_\017 \017$_ + } + unset _ + # ------------------------------ + #REVIEW - see forward/backward map in term::ansi::code::macros::cd::groptim - what are they for?? + proc groptim {string} { + variable grforw + variable grback + set offon \x1b(B\x1b(0 ;#)) ;#editor highlighting comment + set onoff \x1b(0\x1b(B ;#)) ;#editor highlighting comment + while {![string equal $string [set new [string map [list $offon {} $onoff {}] [string map $grback [string map $grforw $string]]]]]} { + set string $new + } + return $string + } + # -------------------------------- + proc ansistrip_gx {text} { #e.g "\033(0" - select VT100 graphics for character set G0 - #e.g "\033(B" - reset + #e.g "\033(B" - reset #e.g "\033)0" - select VT100 graphics for character set G1 #e.g "\033)X" - where X is any char other than 0 to reset ?? - + #return [convert_g0 $text] - return [tcl::string::map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text] + return [tcl::string::map [list \x1b(0 "" \x1b(B "" \x1b)0 "" \x1b)X ""] $text] } proc stripansi_gx {text} { - return [tcl::string::map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text] + return [tcl::string::map [list \x1b(0 "" \x1b(B "" \x1b)0 "" \x1b)X ""] $text] } #CSI m = SGR (Select Graphic Rendition) #leave map unindented - used both as a dict and for direct display variable SGR_setting_map { -reset 0 bold 1 dim 2 italic 3 noitalic 23 +reset 0 bold 1 dim 2 italic 3 noitalic 23 underline 4 doubleunderline 21 nounderline 24 blink 5 fastblink 6 noblink 25 reverse 7 noreverse 27 hide 8 nohide 28 strike 9 nostrike 29 normal 22 defaultfg 39 defaultbg 49 overline 53 nooverline 55 @@ -844,26 +967,26 @@ Black 40 Red 41 Green 42 Yellow 43 Blue brightblack 90 brightred 91 brightgreen 92 brightyellow 93 brightblue 94 brightpurple 95 brightcyan 96 brightwhite 97 Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblue 104 Brightpurple 105 Brightcyan 106 Brightwhite 107 } - variable SGR_map ;#public - part of interface - review + variable SGR_map ;#public - part of interface - review set SGR_map [tcl::dict::merge $SGR_colour_map $SGR_setting_map] #we use prefixes e.g web-white and/or x11-white #Only a leading capital letter will indicate the colour target is background vs lowercase for foreground - #In the map key-lookup context the colour names will be canonically lower case + #In the map key-lookup context the colour names will be canonically lower case #We should be case insensitive in the non-prefix part ie after determining fg/bg target from first letter of the prefix - #e.g Web-Lime or Web-lime are ok and are targeting background + #e.g Web-Lime or Web-lime are ok and are targeting background #foreground target examples: web-Lime web-LIME web-DarkSalmon web-Darksalmon #specified in decimal - but we should also accept hex format directly in a+ function e.g #00FFFF for aqua - variable WEB_colour_map + variable WEB_colour_map #use the totitle format as the canonical lookup key #don't use leading zeros - keep compatible with earlier tcl and avoid octal issue - # -- --- --- + # -- --- --- #css 1-2.0 HTML 3.2-4 Basic colours eg web-silver for fg Web-silver for bg # variable WEB_colour_map_basic tcl::dict::set WEB_colour_map_basic white 255-255-255 ;# #FFFFFF - tcl::dict::set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 + tcl::dict::set WEB_colour_map_basic 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 @@ -878,7 +1001,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 @@ -887,7 +1010,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 @@ -899,7 +1022,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 @@ -907,7 +1030,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_orange darkorange 255-140-0 ;# #FF8C00 tcl::dict::set WEB_colour_map_orange coral 255-127-80 ;# #FF7F50 tcl::dict::set WEB_colour_map_orange orange 255-165-0 ;# #FFA500 - # -- --- --- + # -- --- --- #Yellow colours variable WEB_colour_map_yellow tcl::dict::set WEB_colour_map_yellow darkkhaki 189-183-107 ;# #BDB76B @@ -921,7 +1044,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_yellow lightgoldenrodyeallow 250-250-210 ;# #FAFAD2 tcl::dict::set WEB_colour_map_yellow lemonchiffon 255-250-205 ;# #FFFACD tcl::dict::set WEB_colour_map_yellow lightyellow 255-255-224 ;# #FFFFE0 - # -- --- --- + # -- --- --- #Brown colours #maroon as above variable WEB_colour_map_brown @@ -941,7 +1064,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_brown bisque 255-228-196 ;# #FFEfC4 tcl::dict::set WEB_colour_map_brown blanchedalmond 255-228-196 ;# #FFEfC4 tcl::dict::set WEB_colour_map_brown cornsilk 255-248-220 ;# #FFF8DC - # -- --- --- + # -- --- --- #Purple, violet, and magenta colours variable WEB_colour_map_purple tcl::dict::set WEB_colour_map_purple indigo 75-0-130 ;# #4B0082 @@ -951,7 +1074,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_purple darkslateblue 72-61-139 ;# #9400D3 tcl::dict::set WEB_colour_map_purple blueviolet 138-43-226 ;# #8A2BE2 tcl::dict::set WEB_colour_map_purple darkorchid 153-50-204 ;# #9932CC - tcl::dict::set WEB_colour_map_purple fuchsia 255-0-255 ;# #FF00FF + tcl::dict::set WEB_colour_map_purple fuchsia 255-0-255 ;# #FF00FF tcl::dict::set WEB_colour_map_purple magenta 255-0-255 ;# #FF00FF - same as fuchsia tcl::dict::set WEB_colour_map_purple slateblue 106-90-205 ;# #6A5ACD tcl::dict::set WEB_colour_map_purple mediumslateblue 123-104-238 ;# #7B68EE @@ -962,7 +1085,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_purple plum 221-160-221 ;# #DDA0DD tcl::dict::set WEB_colour_map_purple thistle 216-191-216 ;# #D88FD8 tcl::dict::set WEB_colour_map_purple lavender 230-230-250 ;# #E6E6FA - # -- --- --- + # -- --- --- #Blue colours variable WEB_colour_map_blue tcl::dict::set WEB_colour_map_blue midnightblue 25-25-112 ;# #191970 @@ -980,7 +1103,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_blue lightsteelblue 176-196-222 ;# #B0C4DE tcl::dict::set WEB_colour_map_blue lightblue 173-216-230 ;# #ADD8E6 tcl::dict::set WEB_colour_map_blue powderblue 176-224-230 ;# #B0E0E6 - # -- --- --- + # -- --- --- #Cyan colours #teal as above variable WEB_colour_map_cyan @@ -991,11 +1114,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_cyan mediumturquoise 72-209-204 ;# #48D1CC tcl::dict::set WEB_colour_map_cyan turquoise 64-224-208 ;# #40E0D0 tcl::dict::set WEB_colour_map_cyan aqua 0-255-255 ;# #00FFFF - tcl::dict::set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua + tcl::dict::set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua tcl::dict::set WEB_colour_map_cyan aquamarine 127-255-212 ;# #7FFFD4 tcl::dict::set WEB_colour_map_cyan paleturquoise 175-238-238 ;# #AFEEEE tcl::dict::set WEB_colour_map_cyan lightcyan 224-255-255 ;# #E0FFFF - # -- --- --- + # -- --- --- #Green colours variable WEB_colour_map_green tcl::dict::set WEB_colour_map_green darkgreen 0-100-0 ;# #006400 @@ -1018,7 +1141,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_green lightgreen 144-238-144 ;# #90EE90 tcl::dict::set WEB_colour_map_green greenyellow 173-255-47 ;# #ADFF2F tcl::dict::set WEB_colour_map_green palegreen 152-251-152 ;# #98FB98 - # -- --- --- + # -- --- --- #White colours variable WEB_colour_map_white tcl::dict::set WEB_colour_map_white mistyrose 255-228-225 ;# #FFE4E1 @@ -1038,7 +1161,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_white snow 255-250-250 ;# #FFFAFA tcl::dict::set WEB_colour_map_white ivory 255-255-240 ;# #FFFFF0 tcl::dict::set WEB_colour_map_white white 255-255-255 ;# #FFFFFF - # -- --- --- + # -- --- --- #Gray and black colours variable WEB_colour_map_gray tcl::dict::set WEB_colour_map_gray black 0-0-0 ;# #000000 @@ -1079,8 +1202,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #Xterm colour names (256 colours) - #lists on web have duplicate names - #these have been renamed here in a systematic way: + #lists on web have duplicate names + #these have been renamed here in a systematic way: #They are suffixed with a dash and a letter e.g second deepskyblue4 -> deepskyblue4-b, third deepskyblue4 -> deepskyblue4-c #presumably the xterm colour names are not widely used or are used for reverse lookup from rgb to get an approximate name in the case of dupes? #Review! @@ -1092,10 +1215,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #e.g who is to know that 'Rabbit Paws', 'Forbidden Thrill' and 'Tarsier' refer to a particular shade of pinky-red? (code 95) #Perhaps it's an indication that colour naming once we get to 256 colours or more is a fool's errand anyway. #The xterm names are boringly unimaginative - and also have some oddities such as: - # DarkSlateGray1 which looks much more like cyan.. + # 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? # 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. + #but in general the names bear some resemblance to the colours and are at least somewhat intuitive. set xterm_names [list\ black\ @@ -1377,7 +1500,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {!$did_rename} { - error "Not enough suffixes for duplicate names in xterm colour list. Add more suffixes or review list" + error "Not enough suffixes for duplicate names in xterm colour list. Add more suffixes or review list" } } incr cidx @@ -1387,7 +1510,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #colour_hex2ansidec - #conversion of hex to format directly pluggable to ansi rgb format (colon separated e.g for foreground we need "38;2;$r;$g;$b" so we return $r;$g;$b) + #conversion of hex to format directly pluggable to ansi rgb format (colon separated e.g for foreground we need "38;2;$r;$g;$b" so we return $r;$g;$b) #we want to support arbitrary rgb values specified in hex - so a table of 16M+ is probably not a great idea #hex zero-padded - canonically upper case but mixed or lower accepted #dict for {k v} $WEB_colour_map { @@ -1416,7 +1539,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu variable SGR_map return $SGR_map } - + proc colourmap1 {args} { set opts {-bg Web-white -forcecolour 0} foreach {k v} $args { @@ -1425,7 +1548,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set opts $k $v } default { - error "colourmap1 unrecognised option $k. Known-options: [tcl::dict::keys $opts] + error "colourmap1 unrecognised option $k. Known-options: [tcl::dict::keys $opts]" } } } @@ -1480,7 +1603,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } package require textblock set clist [list] - set fg "black" + set fg "black" for {set i 16} {$i <=231} {incr i} { if {$i % 18 == 16} { if {$fg eq "black"} { @@ -1524,14 +1647,14 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {[tcl::dict::get $opts -forcecolour]} { set fc "forcecolour" } - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-white" + set fg "web-white" set t [textblock::class::table new] $t configure -show_seps 0 -show_edge 0 for {set i 0} {$i <=15} {incr i} { - set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-$i etc instead of term-$name? + set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-$i etc instead of term-$name? if {[llength $row]== 8} { lappend rows $row set row [list] @@ -1563,7 +1686,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fc "forcecolour" } set out "" - set fg "web-black" + set fg "web-black" for {set i 16} {$i <=231} {incr i} { if {$i % 18 == 16} { if {$fg eq "web-black"} { @@ -1571,7 +1694,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { set fg "web-black" } - set br "\n" + set br "\n" } else { set br "" } @@ -1593,10 +1716,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set out "" #use the reverse lookup dict - the original xterm_names list has duplicates - we want the disambiguated (potentially suffixed) names - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-black" + set fg "web-black" set t [textblock::class::table new] $t configure -show_seps 0 -show_edge 0 for {set i 16} {$i <=231} {incr i} { @@ -1769,10 +1892,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fc "forcecolour" } - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-white" + set fg "web-white" set t [textblock::class::table new] $t configure -show_hseps 0 -show_edge 0 for {set i 232} {$i <=255} {incr i} { @@ -1832,7 +1955,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set all_groupnames [list basic brown yellow red pink orange purple blue cyan green white gray] switch -- $groups { "" - * { - set show_groups $all_groupnames + set show_groups $all_groupnames } ? { return "Web group names: $all_groupnames" @@ -1873,7 +1996,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname] } - $t configure -frametype {} + $t configure -frametype {} $t configure_column 0 -headers [list "[tcl::string::totitle $g] colours"] $t configure_column 0 -header_colspans [list any] $t configure -ansibase_header [a+ {*}$fc web-black Web-white] @@ -1966,7 +2089,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #[para]Return an ansi string representing a table of codes and a panel showing the colours variable SGR_setting_map variable SGR_colour_map - set fcposn [lsearch $args "forcecol*"] + set fcposn [lsearch $args "force*"] set fc "" set opt_forcecolour 0 if {$fcposn >= 0} { @@ -1983,7 +2106,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set undercurly "undercurly \[a+ undercurly und-199-21-133\]text\[a] -> [a+ undercurly und-199-21-133]text$RST" set underdotted "underdotted \[a+ underdotted und#FFD700\]text\[a] -> [a+ underdotted und#FFD700]text$RST" set underdashed "underdashed \[a+ underdashed undt-45\]text\[a] -> [a+ underdashed undt-45]text$RST" - set underline_c "named terminal colour SGR underline \[a+ underline undt-deeppink1\]text\[a] -> [a+ underline undt-deeppink1]text$RST" + set underline_c "named terminal colour SGR underline \[a+ underline undt-deeppink1\]text\[a] -> [a+ underline undt-deeppink1]text$RST" append out "${indent}$undercurly $underdotted" \n append out "${indent}$underdashed" \n append out "${indent}$underline_c" \n @@ -1992,7 +2115,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append out "${indent}If a fallback to standard underline is required, underline should be added along with extended codes such as underlinedotted, underlinedouble etc" \n append out "${indent}e.g cyan with curly yellow underline or fallback all cyan underlined \[a+ cyan undercurly underline undt-yellow\]text\[a] -> [a+ {*}$fc cyan undercurly underline undt-yellow]text$RST" \n append out "[a+ {*}$fc web-white]Standard SGR colours and attributes $RST" \n - set settings_applied $SGR_setting_map + set settings_applied $SGR_setting_map set strmap [list] #safe jumptable test #dict for {k v} $SGR_setting_map {} @@ -2016,7 +2139,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu package require overtype ;# circular dependency - many components require overtype. Here we only need it for nice layout in the a? query proc - so we'll do a soft-dependency by only loading when needed and also wrapping in a try package require textblock - append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n + append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n append out [textblock::join -- $indent [tcl::string::trim $SGR_colour_map \n]] \n append out [textblock::join -- $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n set bgname "Web-white" @@ -2095,7 +2218,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - append out "\nNote: The 256 term colours especially 0-15 may be altered by terminal pallette settings or ansi OSC 4 codes, so specific RGB values are unavailable" + 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 { @@ -2125,8 +2248,25 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu switch -- $f4 { web- - Web- - WEB- { set tail [tcl::string::tolower [tcl::string::trim [tcl::string::range $i 4 end] -]] - if {[tcl::dict::exists $WEB_colour_map $tail]} { - set dec [tcl::dict::get $WEB_colour_map $tail] + set cont [string range $tail end-11 end] + switch -- $cont { + -contrasting - -contrastive { + set cname [string range $tail 0 end-12] + } + default { + set cname $tail + } + } + if {[tcl::dict::exists $WEB_colour_map $cname]} { + set dec [tcl::dict::get $WEB_colour_map $cname] + switch -- $cont { + -contrasting { + set dec [join [punk::ansi::colour::contrasting {*}[split $dec -]] -] + } + -contrastive { + set dec [join [lindex [punk::ansi::colour::contrast_pair {*}[split $dec -]] 0] -] + } + } set hex [colour_dec2hex $dec] set descr "$hex $dec" } else { @@ -2147,7 +2287,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {[tcl::dict::exists $TERM_colour_map $tail]} { set descr [tcl::dict::get $TERM_colour_map $tail] } else { - set descr "UNKNOWN colour for term" + set descr "UNKNOWN colour for term" } } $t add_row [list $i $descr $s [ansistring VIEW $s]] @@ -2163,31 +2303,66 @@ 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 - + 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# - + RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 - + rgb# - Rgb# - RGB# - und# - und- { - if {[tcl::string::index $i 3] eq "#"} { - set tail [tcl::string::range $i 4 end] + set cont [string range $i end-11 end] + switch -- $cont { + -contrasting - -contrastive { + set iplain [string range $i 0 end-12] + } + default { + set iplain $i + } + } + if {[tcl::string::index $iplain 3] eq "#"} { + set tail [tcl::string::range $iplain 4 end] set hex $tail set dec [colour_hex2dec $hex] - set info $dec ;#show opposite type as first line of info col + + switch -- $cont { + -contrasting { + set decfinal [join [punk::ansi::colour::contrasting {*}[split $dec -]] -] + set hexfinal [colour_dec2hex $decfinal] + } + -contrastive { + set decfinal [join [lindex [punk::ansi::colour::contrast_pair {*}[split $dec -]] 0] -] + set hexfinal [colour_dec2hex $decfinal] + } + default { + set hexfinal $hex + set decfinal $dec + } + } + set info "$hexfinal $decfinal" ;#show opposite type as first line of info col } else { - set tail [tcl::string::trim [tcl::string::range $i 3 end] -] + set tail [tcl::string::trim [tcl::string::range $iplain 3 end] -] set dec $tail - set hex [colour_dec2hex $dec] - set info $hex + switch -- $cont { + -contrasting { + set decfinal [join [punk::ansi::colour::contrasting {*}[split $dec -]] -] + } + -contrastive { + set decfinal [join [lindex [punk::ansi::colour::contrast_pair {*}[split $dec -]] 0] -] + } + default { + set decfinal $dec + } + } + set hexfinal [colour_dec2hex $decfinal] + set info "$hexfinal $decfinal" } - set webcolours_i [lsearch -all $WEB_colour_map $dec] + set webcolours_i [lsearch -all $WEB_colour_map $decfinal] set webcolours [list] foreach ci $webcolours_i { lappend webcolours [lindex $WEB_colour_map $ci-1] } set x11colours [list] - set x11colours_i [lsearch -all $X11_colour_map $dec] + set x11colours_i [lsearch -all $X11_colour_map $decfinal] foreach ci $x11colours_i { set c [lindex $X11_colour_map $ci-1] if {$c ni $webcolours} { @@ -2204,12 +2379,15 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } unde { switch -- $i { - undercurly - underdotted - underdashed - undersingle - underdouble { + undercurly - undercurl - underdotted - underdot - underdashed - underdash - undersingle - underdouble { $t add_row [list $i extended $s [ansistring VIEW $s]] } underline { $t add_row [list $i "SGR 4" $s [ansistring VIEW $s]] } + underlinedefault { + $t add_row [list $i "SGR 59" $s [ansistring VIEW $s]] + } default { $t add_row [list $i UNKNOWN $s [ansistring VIEW $s]] } @@ -2252,7 +2430,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #REVIEW! note that OSC 4 can change the 256 color pallette - #e.g \x1b\]4\;1\;#HHHHHH\x1b\\ + #e.g \x1b\]4\;1\;#HHHHHH\x1b\\ # (or with colour name instead of rgb #HHHHHH on for example wezterm) #Q: If we can't detect OSC 4 - how do we know when to invalidate/clear at least the 256 color portion of the cache? @@ -2264,16 +2442,23 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set sgr_cache [tcl::dict::create] #sgr_cache clear called by punk::console::ansi when set to off - proc sgr_cache {args} { - set argd [punk::args::get_dict { - *proc -name punk::ansi::sgr_cache -help "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) - " - -action -default "" -choices "clear" -help "-action clear will unset the keys in the punk::ansi::sgr_cache dict - This is called automatically when setting 'colour false' in the console" - -pretty -default 1 -type boolean -help "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" - *values -min 0 -max 0 - } $args] + #punk::args depends on punk::ansi - REVIEW + lappend PUNKARGS [list { + @id -id ::punk::ansi::sgr_cache + @cmd -name punk::ansi::sgr_cache -help\ + "Convenience function to view and optionally clear the ansi character attribute cache + (ansi SGR codes)" + -action -default "" -choices "clear" -help\ + "-action clear will unset the keys in the punk::ansi::sgr_cache dict + This is called automatically when setting 'colour false' in the console" + + -pretty -default 1 -type boolean -help\ + "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" + @values -min 0 -max 0 + }] + proc sgr_cache {args} { + set argd [punk::args::get_by_id ::punk::ansi::sgr_cache $args] set action [dict get $argd opts -action] set pretty [dict get $argd opts -pretty] @@ -2307,23 +2492,24 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set linelen $thislen } else { append line "$ansi$key$RST " - incr linelen $thislen + incr linelen $thislen } } if {[tcl::string::length $line]} { lappend lines $line } - return [join $lines \n] + return [join $lines \n] } + #PUNKARGS doc performed below, after we create the proc proc a+ {args} { #*** !doctools #[call [fun a+] [opt {ansicode...}]] #[para]Returns the ansi code to apply those from the supplied list - without any reset being performed first - #[para] e.g to set foreground red and bold + #[para] e.g to set foreground red and bold #[para]punk::ansi::a red bold #[para]to set background red - #[para]punk::ansi::a Red + #[para]punk::ansi::a Red #[para]see [cmd punk::ansi::a?] to display a list of codes #function name part of cache-key because a and a+ return slightly different results (a has leading reset) @@ -2346,13 +2532,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything. set forcecolour 0 - set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour + set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour if {$fcpos >= 0} { set forcecolour 1 set args [lremove $args $fcpos] } - set t [list] + 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] @@ -2361,10 +2547,31 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #variable WEB_colour_map #upvar ::punk::ansi::WEB_colour_map WEB_colour_map #foreground web colour - set cname [tcl::string::tolower [tcl::string::range $i 4 end]] + set tail [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 + } + } if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] - set rgb [tcl::string::map { - ;} $rgbdash] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] + switch -- $cont { + -contrasting { + set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] + } + -contrastive { + set rgb [join [lindex [punk::ansi::colour::contrast_pair {*}[split $rgbdash -]] 0] {;}] + } + default { + set rgb [tcl::string::map { - ;} $rgbdash] + } + } lappend t "38;2;$rgb" } else { puts stderr "ansi web colour unmatched: '$i' in call 'a+ $args'" @@ -2374,9 +2581,30 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #variable WEB_colour_map #upvar ::punk::ansi::WEB_colour_map WEB_colour_map #background web colour - set cname [tcl::string::tolower [tcl::string::range $i 4 end]] + set tail [tcl::string::tolower [tcl::string::range $i 4 end]] + set cont [string range $tail end-11 end] + switch -- $cont { + -contrasting - -contrastive { + set cname [string range $tail 0 end-12] + } + default { + set cname $tail + } + } if {[tcl::dict::exists $WEB_colour_map $cname]} { - lappend t "48;2;[tcl::string::map {- ;} [tcl::dict::get $WEB_colour_map $cname]]" + set rgbdash [tcl::dict::get $WEB_colour_map $cname] + switch -- $cont { + -contrasting { + set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] + } + -contrastive { + set rgb [join [lindex [punk::ansi::colour::contrast_pair {*}[split $rgbdash -]] 0] {;}] + } + default { + set rgb [tcl::string::map { - ;} $rgbdash] + } + } + lappend t "48;2;$rgb" } else { puts stderr "ansi Web colour unmatched: '$i' in call 'a+ $args'" } @@ -2401,11 +2629,14 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 + # 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 @@ -2419,13 +2650,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu underdouble { lappend e 4:2 } - undercurly { + undercurly - undercurl { lappend e 4:3 } - underdotted { + underdotted - underdot { lappend e 4:4 } - underdashed { + underdashed - underdash { lappend e 4:5 } default { @@ -2458,7 +2689,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } default { puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } + } } } nohi {lappend t 28 ;#nohide} @@ -2518,10 +2749,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend t "38;5;$cc" + lappend t "38;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term colour unmatched: '$i' in call 'a+ $args'" } @@ -2532,63 +2763,127 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #256 colour background by Xterm name or by integer set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] && $cc < 256} { - lappend t "48;5;$cc" + lappend t "48;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi Term colour unmatched: '$i' in call 'a+ $args'" } } } - 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- - 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 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" + #decimal rgb foreground/background + #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx + + set cont [string range $i end-11 end] + switch -- $cont { + -contrasting - -contrastive { + set iplain [string range $i 0 end-12] + } + default { + set iplain $i + } + } + set rgbspec [tcl::string::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] {;}] + } + -contrastive { + set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {;}] + } + default { + set rgbfinal [join $RGB {;}] + } + } + if {[tcl::string::index $i 0] eq "r"} { + #fg + lappend t "38;2;$rgbfinal" + } else { + #bg + lappend t "48;2;$rgbfinal" + } } - "Rgb#" - "RGB#" { - #hex rgb background + "rgb#" - "Rgb#" - "RGB#" { set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] - set rgb [join [::scan $hex6 %2X%2X%2X] {;}] - lappend t "48;2;$rgb" + #set rgb [join [::scan $hex6 %2X%2X%2X] {;}] + set RGB [::scan $hex6 %2X%2X%2X] + set cont [string range $i end-11 end] + switch -- $cont { + -contrasting { + set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {;}] + } + -contrastive { + set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {;}] + } + default { + set rgbfinal [join $RGB {;}] + } + } + if {[tcl::string::index $i 0] eq "r"} { + #hex rgb foreground + lappend t "38;2;$rgbfinal" + } else { + #hex rgb background + lappend t "48;2;$rgbfinal" + } } und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx + #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 [tcl::string::map [list - {:} , {:}] $rgbspec] - lappend e "58:2::$rgb" + set RGB [lrange [tcl::string::map [list - { } , { } {;} { }] $rgbspec] 0 2] + #puts "---->'$RGB'<----" + set cont [string range $i end-11 end] + switch -- $cont { + -contrasting { + set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {:}] + } + -contrastive { + set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {:}] + } + default { + set rgbfinal [join $RGB {:}] + } + } + #lappend e "58:2:$rgbfinal" ;# - no colorspace ID - some terminals support? which? + lappend e "58:2::$rgbfinal" } "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + #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" + #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 + #CSI 58 : 5 : INDEX m #variable TERM_colour_map #256 colour underline by Xterm name or by integer #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend e "58:5:$cc" + lappend e "58:5:$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" + lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" } @@ -2599,7 +2894,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { @@ -2611,7 +2906,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { @@ -2632,10 +2927,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #the performance penalty must not be placed on the standard colour_enabled path. #This is punk. Colour is the happy path despite the costs. - #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. - #As no_color doesn't strip all ansi - the motivation for it should not generally be + #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. + #As no_color doesn't strip all ansi - the motivation for it should not generally be if {$colour_disabled && !$forcecolour} { - set tkeep [list] + set tkeep [list] foreach code $t { switch -- $code { 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { @@ -2645,7 +2940,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } set t $tkeep - set ekeep [list] + set ekeep [list] foreach code $e { switch -- $code { 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { @@ -2674,15 +2969,51 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return $result } + set SGR_samples [dict create] + foreach k [dict keys $SGR_map] { + #indent of 1 space is important for clarity in i -return string a+ output + dict set SGR_samples $k " [punk::ansi::a+ $k]sample\x1b\[m" + } + lappend PUNKARGS [list { + @id -id ::punk::ansi::a+ + @cmd -name "punk::ansi::a+" -help\ + "Returns an ANSI sgr escape sequence based on the list of supplied codes. + Unlike punk::ansi::a - it is not prefixed with an ANSI reset. + " + @values -min 0 -max -1 + } [string map [list [dict keys $SGR_map] $SGR_samples] { + code -type string -optional 1 -multiple 1 -choices {}\ + -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]\" + " + }]] + proc a {args} { #*** !doctools #[call [fun a] [opt {ansicode...}]] #[para]Returns the ansi code to reset any current settings and apply those from the supplied list - #[para] by calling punk::ansi::a with no arguments - the result is a reset to plain text - #[para] e.g to set foreground red and bold + #[para] by calling punk::ansi::a with no arguments - the result is a reset to plain text + #[para] e.g to set foreground red and bold #[para]punk::ansi::a red bold #[para]to set background red - #[para]punk::ansi::a Red + #[para]punk::ansi::a Red #[para]see [cmd punk::ansi::a?] to display a list of codes #It's important to put the functionname in the cache-key because a and a+ return slightly different results @@ -2704,13 +3035,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything. set forcecolour 0 - set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour + set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour if {$fcpos >=0} { set forcecolour 1 set args [lremove $args $fcpos] } - set t [list] + 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] @@ -2721,7 +3052,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground web colour set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] set rgb [tcl::string::map { - ;} $rgbdash] lappend t "38;2;$rgb" } else { @@ -2761,6 +3092,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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) @@ -2774,13 +3108,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu underdouble { lappend e 4:2 } - undercurly { + undercurly - undercurl { lappend e 4:3 } - underdotted { + underdotted - underdot { lappend e 4:4 } - underdashed { + underdashed - underdash { lappend e 4:5 } default { @@ -2813,7 +3147,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } default { puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } + } } } nohi {lappend t 28 ;#nohide} @@ -2873,10 +3207,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend t "38;5;$cc" + lappend t "38;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term colour unmatched: '$i' in call 'a $args'" } @@ -2887,10 +3221,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #256 colour background by Xterm name or by integer set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] && $cc < 256} { - lappend t "48;5;$cc" + lappend t "48;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi Term colour unmatched: '$i' in call 'a $args'" } @@ -2898,7 +3232,7 @@ 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 + #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" @@ -2922,14 +3256,14 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 + #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 + #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" @@ -2940,10 +3274,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend e "58:5:$cc" + lappend e "58:5:$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" + lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" } @@ -2954,7 +3288,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { @@ -2966,7 +3300,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { @@ -2984,9 +3318,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - + if {$colour_disabled && !$forcecolour} { - set tkeep [list] + set tkeep [list] foreach code $t { switch -- $code { 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { @@ -2996,7 +3330,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } set t $tkeep - set ekeep [list] + set ekeep [list] foreach code $e { switch -- $code { 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { @@ -3020,7 +3354,55 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return $result } - proc ansiwrap {codes text} { + lappend PUNKARGS [list { + @id -id ::punk::ansi::ansiwrap + @cmd -name punk::ansi::ansiwrap -help\ + "Wrap a string with ANSI codes from + supplied codelist(s) followed by trailing + ANSI reset. + + Codes are numbers or strings as indicated + in the output of the colour information + function: punk::ansi::a? + + No leading reset is applied - so when + placing resultant text, any existing + SGR codes that aren't overridden may + still take effect. + + For finer control use the a+ and a + functions eg + set x \"[a+ red]text [a+ bold]etc[a]\" + " + @leaders -min 0 -max -1 + codelist -multiple 1 -default {} -type list -help\ + "ANSI names/ints as understood by 'a?' + (Not actual ANSI as output by a+) + These can be supplied individually or + as a list or lists" + @values -min 1 -max 1 + text -type string -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 + punk::args::parse $args withid ::punk::ansi::ansiwrap + return + } + set text [lindex $args end] + set codelists [lrange $args 0 end-1] + set codes [concat {*}$codelists] ;#flatten return [a {*}$codes]$text[a] } @@ -3049,18 +3431,26 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun reset]] #[para]reset console - return "\x1bc" + return "\x1bc" } proc reset_soft {} { #*** !doctools #[call [fun reset_soft]] return \x1b\[!p } + proc SYN {} { + #syn seems to disable alternate graphics mode temporarily on modern terminals + return \016 + } + proc ETB {} { + #This is a form of soft reset for the state where a SYN was sent - re-enabling altg processing + return \017 + } proc reset_colour {} { #*** !doctools #[call [fun reset_colour]] #[para]reset colour only - return "\x1b\[0m" + return "\x1b\[0m" } # -- --- --- --- --- @@ -3097,8 +3487,76 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #[call [fun cursor_off]] return "\033\[?25l" } + proc cursor_on_vt52 {} { + return \x1be + } + proc cursor_off_vt52 {} { + return \x1bf + } + + # REVIEW - osc8 replays etc for split lines? - textblock + #Hyperlinks (a.k.a. HTML-like anchors) in terminal emulators https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda + #the 'id' parameter logically connects split hyperlinks + #per interp. Rather than try to avoid collisions using something like 'info cmdcount' we will use a simple counter. + #To stop multiple hyperlinks from having ids inadvertently collide - we should do some id mangling/prefixing based on the terminal/window etc + #It is better to use a simple counter with high likelihood of collision so we are more likely to detect problems with ids than to make it more intermittent by using ids that collide only 'rarely' + variable hyperlinkcounter + set hyperlinkcounter 0 + + + proc hyperlink {uri {display ""}} { + variable hyperlinkcounter + if {$display eq ""} { + set display $uri + } + set uri [punk::ansi::ansistripraw $uri] + #limit uri length we emit based on common limits in other terminals + if {[string length $uri] > 2083} { + error "punk::ansi::hyperlink uri too long: limit 2083" + } + set params "id=punkansi-[incr hyperlinkcounter]" ;#todo e.g id=xyz123:foo=bar:baz=quux + set open "\x1b\]8\;$params\;$uri\x1b\\" + set close "\x1b\]8\;\;\x1b\\" + return ${open}${display}${close} + } + + #on windows terminal at least, both uri and id of 2 separated hyperlinks need to match for the hover highlighting to act as a unit. + proc hyperlink_open {uri {id ""}} { + if {$id eq ""} { + set id punkansi-[incr hyperlinkcounter] + } + set uri [punk::ansi::ansistripraw $uri] + if {[string length $uri] > 2083} { + error "punk::ansi::hyperlink uri too long: limit 2083" + } + set id [string map {: . {;} ,} $id] ;#avoid some likely problematic ids. TODO - review, restrict further. + set params "id=$id" + return "\x1b\]8\;$params\;$uri\x1b\\" + } + #It should be ok to close even if no currently active hyperlink (e.g can be used to cleanup if something awry) + proc hyperlink_close {} { + return "\x1b\]8\;\;\x1b\\" + } # -- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::punk::ansi::move + @cmd -name punk::ansi::move -help\ + {Return an ANSI sequence to move cursor to row,col + (aka: cursor home) + + Sequence is of the form: + \x1b[;H + (CSI row ; col H) + This sequence will not be understood by old vt52 + terminals. see also vt52_move. + } + @values -min 2 -max 2 + row -type integer -help\ + "row number - starting at 1" + col -type integer -help\ + "column number - starting at 1" + }] proc move {row col} { #*** !doctools #[call [fun move] [arg row] [arg col]] @@ -3106,10 +3564,48 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #[para]aka cursor home return \033\[${row}\;${col}H } + #NOTE vt52 uses ESC Y line column + # where line and column are ascii codes whose values are +31 + # vt52 can be entered/exited via escapes + # This means we probably need to to wrap enter/exit vt52 and keep this state - as we don't have a standard way to query for terminal type + # (vt52 supports ESC Z - but vt100 sometimes? doesn't - and querying at each output would be slow anyway, even if there was a common query :/ ) + + lappend PUNKARGS [list { + @id -id ::punk::ansi::vt52move + @cmd -name punk::ansi::vt52move -help\ + {Return a VT52 sequence to move cursor to row,col + (aka: cursor home) + + Sequence is of the form: + ESCY + This sequence will generally not be understood by terminals + that are not in vt52 mode (e.g DECANM unset). + } + @values -min 2 -max 2 + row -type integer -help\ + "row number - starting at 1" + col -type integer -help\ + "column number - starting at 1" + }] + proc vt52move {row col} { + #test + set r [format %c [expr {$row + 31}]] + set c [format %c [expr {$col + 31}]] + return \x1bY${r}${c} + } + proc vt52color {int} { + if {[string is integer -strict $int]} { + if {$int < 0 || $int > 15} { + error "vt52color unsupported - only 0 to 15 available" + } + } + set char [format %c [expr {$int + 31}]] + return \x1bb${char} + } proc move_emit {row col data args} { #*** !doctools #[call [fun move_emit] [arg row] [arg col] [arg data] [opt {row col data...}]] - #[para]Return an ansi string representing a move to row col with data appended + #[para]Return an ansi string representing a move to row col with data appended #[para]row col data can be repeated any number of times to return a string representing the output of the data elements at all those points #[para]Compare to punk::console::move_emit which calls this function - but writes it to stdout #[para]punk::console::move_emit_return will also return the cursor to the original position @@ -3136,31 +3632,94 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } return $out } + proc vt52move_emit {row col data args} { + #Todo - G code? + set out "" + if {$row eq "this"} { + #append out \033\[\;${col}G$data + append out [vt52move_column $col]$data + } else { + #append out \033\[${row}\;${col}H$data + append out [vt52move $row $col]$data + } + foreach {row col data} $args { + if {$row eq "this"} { + append out [vt52move_column $col]$data + #append out \033\[\;${col}G$data + } else { + #append out \033\[${row}\;${col}H$data + append out [vt52move $row $col]$data + } + } + return $out + } + proc move_emitblock {row col textblock} { + #*** !doctools + #[call [fun move_emitblock] [arg row] [arg col] [arg textblock]] + set commands "" + foreach ln [split $textblock \n] { + append commands [punk::ansi::move_emit $row $col $ln] + incr row + } + return $commands + } + proc vt52move_emitblock {row col textblock} { + #*** !doctools + #[call [fun move_emitblock] [arg row] [arg col] [arg textblock]] + set commands "" + foreach ln [split $textblock \n] { + append commands [punk::ansi::vt52move_emit $row $col $ln] + incr row + } + return $commands + } proc move_forward {{n 1}} { #*** !doctools #[call [fun move_forward] [arg n]] return \033\[${n}C } + proc vt52move_forward {{n 1}} { + return [string repeat \x1bC $n] + } proc move_back {{n 1}} { #*** !doctools #[call [fun move_back] [arg n]] return \033\[${n}D } + proc vt52move_back {{n 1}} { + return [string repeat \x1bD $n] + } proc move_up {{n 1}} { #*** !doctools #[call [fun move_up] [arg n]] return \033\[${n}A } + proc vt52move_up {{n 1}} { + return [string repeat \x1bA $n] + } proc move_down {{n 1}} { #*** !doctools #[call [fun move_down] [arg n]] return \033\[${n}B } + proc vt52move_down {{n 1}} { + return [string repeat \x1bB $n] + } proc move_column {col} { #*** !doctools #[call [fun move_column] [arg col]] return \x1b\[${col}G } + proc vt52move_column {col} { + #This is a bit of a fudge - as there is no command to move to a specific column. + #without tracking state - we settle for moving back enough times to ensure we're at column 1 - and then move forward. + #inefficient - but will have to do I guess. + #review - max term width vt52? env var LINES and env var COLUMNS ? + # also ESC R CR - set window size + set back [string repeat \x1bD 132] + set fwd [string repeat \x1bC [expr {$col - 1}]] + return $back$fwd + } proc move_row {row} { #*** !doctools #[call [fun move_row] [arg row]] @@ -3198,7 +3757,36 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #[para] DECRC return \x1b8 } + proc cursor_save_vt52 {} { + return \x1bj + } + proc cursor_restore_vt52 {} { + return \x1bk + } + # -- --- --- --- --- + #CRM Show Control Character Mode + proc enable_crm {} { + return \x1b\[3h + } + proc disable_crm {} { + return \x1b\[3l + } + + #DECSNM + #Note this can invert the enclosed section including any already reversed by SGR 7 - depending on terminal support. + #e.g + #set test [a+ reverse]aaa[a+ noreverse]bbb + # - $test above can't just be reversed by putting another [a+ reverse] in front of it. + # - but the following will work (even if underlying terminal doesn't support ?5 sequences) + #overtype::renderspace -width 20 [enable_inverse]$test + proc enable_inverse {} { + return \x1b\[?5h + } + proc disable_inverse {} { + return \x1b\[?5l + } + #DECAWM - automatic line wrapping proc enable_line_wrap {} { @@ -3217,31 +3805,243 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #tput rmam return \x1b\[?7l } - proc query_mode_line_wrap {} { - #*** !doctools - #[call [fun query_mode_line_wrap]] - #[para] DECRQM to query line-wrap state - #[para] The punk::ansi::query_mode_ functions just emit the ansi query sequence. - return \x1b\[?7\$p + + + proc query_mode_line_wrap {} { + #*** !doctools + #[call [fun query_mode_line_wrap]] + #[para] DECRQM to query line-wrap state + #[para] The punk::ansi::query_mode_ functions just emit the ansi query sequence. + return \x1b\[?7\$p + } + #DECRPM responses e.g: + # \x1b\[?7\;1\$y + # \x1b\[?7\;2\$y + #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + + #https://wiki.tau.garden/dec-modes/ + #(DEC,xterm,contour,mintty,kitty etc) + #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking + + #names for other alt_screen mechanismk: 1047,1048 vs 1049? + #variable decmode_names [dict create\ + # DECANM 2\ + # origin 6\ + # DECCOLM 3\ + # line_wrap 7\ + # LNM 20\ + # alt_screen 1049\ + # grapheme_clusters 2027\ + # bracketed_paste 2004\ + # mouse_sgr 1006\ + # mouse_urxvt 1015\ + # mouse_sgr_pixel 1016\ + #] + variable decmode_data { + 1 { + {origin DEC description "DECCKM - Cursor Keys Mode" names {DECCKM cursor_keys}} + } + 2 { + {origin DEC description "DECANM - ANSI/VT52 Mode" names {DECANM} note { +Disable to turn on VT52 emulation. +In VT52 mode - use \x1b< to exit. + } + } + } + 3 { + {origin DEC description "DECCOLM - Column" names {DECCOLM}} + } + 4 { + {origin DEC description "DECSCLM - Scrolling" names {DECSCLM}} + } + 5 { + {origin DEC description "DECSCNM - Screen Mode (light or dark screen)" names {DECSNM lightmode}} + } + 7 { + {origin DEC description "DECAWM - Auto Wrap Mode" names {DECAWM line_wrap}} + } + 9 { + {origin "xterm" description "X10 compatibility mouse" names {SET_X10_MOUSE mouse_tracking} note { +Escape sequence on button press only. +CSI M CbCxCy (6 chars) +Coords limited to 223 (=255 - 32) + } + } + {origin DEC description "DECINLM - Interlace Mode (obsolete?)" names {DECINLM}} + } + 20 { + {origin DEC description "LNM - Line Feed/New Line Mode" names {LNM} note { +For terminals that support LNM, the default is off +meaning a lone CR respresents the character emitted +when enter is pushed. Turning LNM on would mean that +CR LF is sent when hitting enter. This feature is +not commonly supported, and the default will normally +be as if this was off - ie lone CR. + } + } + } + 25 { + {origin DEC description "DECTCEM - Text Cursor Enable Mode" names {DECTCEM cursor_enable}} + } + 47 { + {origin xterm description "xterm alternate buffer" names {xterm_altbuf}} + {origin DEC description "DECGRPM - Graphics Rotated Print Mode (obsolete?)" names {DECGRPM}} + } + 66 { + {origin DEC description "DECNKM - Numeric Keypad Mode" names {DECNKM}} + } + 1000 { + {origin "xterm" description "VT200 compatibility mouse" names {SET_VT200_MOUSE} note { +Escape sequence on both button press and release. +CSI M CbCxCy + } + } + } + 1004 { + {origin "xterm" description "Send FocusIn/FocusOut events" names {mouse_focus_event}} + } + 1005 { + {origin "xterm" description "Enable UTF-8 Mouse Mode" names {mouse_utf8 mouse_utf8_extended}} + } + 1006 { + {origin "xterm" description "Enable SGR Mouse Mode" names {mouse_sgr mouse_sgr_extended} note{ +SET_SGR_EXT_MODE_MOUSE - extended compared to x10 mouse protocol which limits x y coords +to 223 (=255 - 32) + } + } + } + 1015 { + {origin "urxvt" description "Enable urxvt Mouse Mode" names {mouse_urxvt}} + } + 1016 { + {origin "xterm" description "Enable SGR Pixel Mouse Mode" names {mouse_sgr_pixel}} + } + 1047 { + {origin "xterm" description "Alternate Buffer" names {alt_buffer_only}} + } + 1049 { + {origin "xterm" description "Alternate Buffer with save cursor" names {alt_buffer alt_screen}} + } + 2004 { + {origin "xterm" description "Set bracketed paste mode" names {bracketed_paste}} + } + 2027 { + {origin Contour description "Grapheme Cluster Processing" names {grapheme_clusters}} + } + } + set decmode_names [dict create] + dict for {code items} $decmode_data { + foreach itm $items { + set names [dict get $itm names] + foreach nm $names { + dict set decmode_names $nm $code + } + } + } + + + + + + proc query_mode {num_or_name} { + if {[string is integer -strict $num_or_name]} { + set m $num_or_name + } else { + variable decmode_names + if {[dict exists $decmode_names $num_or_name]} { + set m [dict get $decmode_names $num_or_name] + } else { + error "punk::ansi::query_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" + } + } + return "\x1b\[?$m\$p" } - #DECRPM responses e.g: - # \x1b\[?7\;1\$y - # \x1b\[?7\;2\$y - #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - #Alt screen buffer + #Alt screen buffer - smcup/rmcup ti/te + #Note \x1b\[?47h doesn't work at all in some terminals (e.g alacritty,cmd on windows and reportedly kitty) + #It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals. + #see: https://xn--rpa.cc/irl/term.html + #1049 (introduced by xterm in 1998?) considered the more modern version? + #1047,1048,1049 xterm private modes are 'composite' control sequences as replacement for original 47 sequence + #1049 - includes save cursor,switch to alt screen, clear screen + #e.g ? (below example not known to be exactly what 1049 does - but it's something similar) + #SMCUP + # \x1b7 (save cursor) + # \x1b\[?47h (switch) + # \x1b\[2J (clear screen) + #RMCUP + # \x1b\[?47l (switch back) + # \x1b8 (restore cursor) + + #1047 - clear screen on the way out (ony if actually on alt screen) proc enable_alt_screen {} { - #tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen? - #\x1b\[?1049h ;#xterm - return \x1b\[?47h + #tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen? + return \x1b\[?1049h } proc disable_alt_screen {} { #tput rmcup outputs \x1b\[?1049l\x1b\[23\;0\;0t] - #\x1b\[?1049l + return \x1b\[?1049l + } + #47 - less widely supported(?) doesn't restore cursor or clear alt screen + proc enable_alt_screen2 {} { + return \x1b\[?47h + } + proc disable_alt_screen2 {} { return \x1b\[?47l } + proc term_colour_fg {colour} { + return "\x1b\]10\;$colour\x1b\\" + } + proc term_color_fg {colour} { + return "\x1b\]10\;$colour\x1b\\" + } + proc term_colour_bg {colour} { + return "\x1b\]11\;$colour\x1b\\" + } + proc term_color_bg {colour} { + return "\x1b\]11\;$colour\x1b\\" + } + proc term_colour_cursor {colour} { + return "\x1b\]12\;$colour\x1b\\" + } + proc term_color_cursor {colour} { + return "\x1b\]12\;$colour\x1b\\" + } + proc term_colour_pointer_fg {colour} { + return "\x1b\]13\;$colour\x1b\\" + } + proc term_color_pointer_fg {colour} { + return "\x1b\]13\;$colour\x1b\\" + } + proc term_colour_pointer_bg {colour} { + return "\x1b\]14\;$colour\x1b\\" + } + proc term_color_pointer_bg {colour} { + return "\x1b\]14\;$colour\x1b\\" + } + #15,16 tektronix fg, tektronix bg ??? + proc term_colour_highlight_bg {colour} { + return "\x1b\]17\;$colour\x1b\\" + } + proc term_color_highlight_bg {colour} { + return "\x1b\]17\;$colour\x1b\\" + } + #18 tektronix cursor colour ??? + proc term_colour_highlight_fg {colour} { + return "\x1b\]19\;$colour\x1b\\" + } + proc term_color_highlight_fg {colour} { + return "\x1b\]19\;$colour\x1b\\" + } + #22 pointer shape - there are other methods too - not known to work on windows terminal based VTs - review + proc term_colour_reset {} { + return "\x1b\]104\;\x1b\\" + } + proc term_color_reset {} { + return "\x1b\]104\;\x1b\\" + } # -- --- --- proc erase_line {} { @@ -3255,11 +4055,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #[para]Erase to start of line, leaving cursor position alone. return \033\[1K } + proc vt52erase_sol {} { + return \x1bo + } proc erase_eol {} { #*** !doctools #[call [fun erase_eol]] return \033\[K } + proc vt52erase_eol {} { + return \x1bK + } #see also clear_above clear_below # -- --- --- --- --- @@ -3308,12 +4114,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #[para]Use punk::console::get_cursor_pos or punk::console::get_cursor_pos_list instead. #[para]These functions will emit the code - but read it in from stdin so that it doesn't display, and then return the row and column as a colon-delimited string or list respectively. #[para]The punk::ansi::cursor_pos function is used by punk::console::get_cursor_pos and punk::console::get_cursor_pos_list - return \033\[6n + return \033\[6n } - + proc cursor_pos_extended {} { #includes page e.g ^[[47;3;1R - return \033\[?6n + #(but not on all terminals - some (freebsd?) will report as per 6n e.g ^[[74;3R) + return \033\[?6n } @@ -3321,7 +4128,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #REVIEW - vt100 accepts decimal values 132-126 and 160-255 ("in the current GL or GR in-use table") #some modern terminals accept and display characters outside this range - but this needs investigation. #in a modern unicode era - the restricted range doesn't make a lot of sense - but we need to see what terminal emulators actually do. - #e.g what happens with double-width? + #e.g what happens with double-width? #this wrapper accepts a char rather than a decimal value proc fill_rect {char t l b r} { set dec [scan $char %c] @@ -3362,7 +4169,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } - #alternative to string terminator is \007 - + #alternative to string terminator is \007 - proc titleset {windowtitle} { #*** !doctools #[call [fun titleset] [arg windowtitles]] @@ -3370,8 +4177,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #[para]This may not work on terminals which have multiple panes/windows return "\033\]2;$windowtitle\033\\" ;#works for xterm and most derivatives } + proc vt52titleset {windowtitle} { + return \x1bS$windowtitle\r + } #titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title - #no cross-platform ansi-only mechanism ? + #no cross-platform ansi-only mechanism ? proc test_decaln {} { #Screen Alignment Test @@ -3379,13 +4189,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #(doesn't work on many terminals - seems to work in FreeBSD 13.2 and wezterm on windows) return \x1b#8 } - + #length of text for printing characters only #- unicode and other non-printing chars and combining sequences should be handled by the ansifreestring_width call at the end. #certain unicode chars are full-width (single char 2 columns wide) e.g see "Halfwdith and fullwidth forms" and ascii_fuillwidth blocks in punk::char::charset_names #review - is there an existing library or better method? printing to a terminal and querying cursor position is relatively slow and terminals lie. #Note this length calculation is only suitable for lines being appended to other strings if the line is pre-processed to account for backspace and carriage returns first - #If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. + #If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. proc printing_length {line} { #string last faster than string first for long strings anyway if {[tcl::string::last \n $line] >= 0} { @@ -3393,12 +4203,15 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #what if line has \v (vertical tab) ie more than one logical screen line? - #review - detect ansi moves and warn/error? They would invalidate this algorithm + #review - detect ansi moves and warn/error? They would invalidate this algorithm #for a string with ansi moves - we would need to use the overtype::renderline function (which is a bit heavier) #arguably - \b and \r are cursor move operations too - so processing them here is not very symmetrical - review #the purpose of backspace (or line cr) in embedded text is unclear. Should it allow some sort of character combining/overstrike as it has sometimes done historically (nroff/less)? e.g a\b` as an alternative combiner or bolding if same char #This should presumably only be done if the over_strike (os) capability is enabled in the terminal. Either way - it presumably won't affect printing width? set line [punk::ansi::ansistrip $line] + #ANSI (e.g PM/SOS) can contain \b or \n or \t but won't contribute to length + #ansistrip must come before any other processing of these chars. + #we can't use simple \b processing if we get ansi codes and aren't actually processing them (e.g moves) set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after ansistrip - some like BEL are part of ansi @@ -3424,7 +4237,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #NOTE - this is non-destructive backspace as it occurs in text blocks - and is likely different to the sequence coming from a terminal or editor which generally does a destructive backspace - #e.g + #e.g #This means for example that abc\b has a length of 3. Trailing or leading backslashes have no effect #set bs [format %c 0x08] @@ -3447,16 +4260,16 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #mintty seems more 'correct'. It will backspace over an entire grapheme (char+combiners) whereas windows terminal/wezterm etc remove a combiner - #build an output + #build an output set idx 0 set outchars [list] set outsizes [list] # -- - #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code + #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code #this is difficult/risky to maintain - hence the lsearch and grapheme-replacement above #we could reasonably do it with backspace - but cr is more difficult #note that \x08 \b etc won't work to create a compiled switch statement even with unbraced (separate argument) form of switch statement. - #set bs "" + #set bs "" #set cr ? # -- foreach c $chars { @@ -3470,10 +4283,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set idx 0 } default { - #set nxt [llength $outchars] + #set nxt [llength $outchars] if {$idx < [llength $outchars]} { #overstrike? - should usually have no impact on width - width taken as last grapheme in that column - #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done + #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. lset outchars $idx $c } else { @@ -3523,24 +4336,43 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #[call [fun ansistrip] [arg text] ] #[para]Return a string with ansi codes stripped out #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) - + if {[string length $text] < 2} {return $text} if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } + if {[string length $text] < 2} {return $text} set parts [punk::ansi::ta::split_codes $text] + if {[llength $parts] == 1} {return [lindex $parts 0]} set out "" + #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" + # - (if/when lsearch -stride bug fixed) foreach {pt code} $parts { append out $pt } return $out } + proc ansistrip2 {text} { + #*** !doctools + #[call [fun ansistrip2] [arg text] ] + #[para]Return a string with ansi codes stripped out + #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) + + if {[punk::ansi::ta::detect_g0 $text]} { + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + } + set parts [punk::ansi::ta::split_codes $text] + #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" + # - (if/when lsearch -stride bug fixed) + join [lmap v [lseq 0 to [llength $parts] by 2] {lindex $parts $v}] "" ;#slightly slower than above foreach + } #interp alias {} stripansi {} ::punk::ansi::ansistrip proc ansistripraw {text} { #*** !doctools #[call [fun ansistripraw] [arg text] ] - #[para]Return a string with ansi codes stripped out + #[para]Return a string with ansi codes stripped out #[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode. - #[para]ie instead of a horizontal line you may see: qqqqqq + #[para]ie instead of a horizontal line you may see: qqqqqq + if {[string length $text] < 2} {return $text} set parts [punk::ansi::ta::split_codes $text] set out "" @@ -3571,7 +4403,7 @@ tcl::namespace::eval punk::ansi { # name (one not found in xterm's tables) ends processing of the # list of names. proc xtgetcap {keylist} { - #ESC P = 0x90 = DCS = Device Control String + #ESC P = 0x90 = DCS = Device Control String set hexkeys [list] foreach k $keylist { lappend hexkeys [util::str2hex $k] @@ -3580,7 +4412,7 @@ tcl::namespace::eval punk::ansi { return "\x1bP+q$payload\x1b\\" } proc xtgetcap2 {keylist} { - #ESC P = 0x90 = DCS = Device Control String + #ESC P = 0x90 = DCS = Device Control String set hexkeys [list] foreach k $keylist { lappend hexkeys [util::str2hex $k] @@ -3600,8 +4432,8 @@ tcl::namespace::eval punk::ansi { #review - separate namespace for functions that operate on multiple or embedded? proc is_sgr {code} { - #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline - #we will accept and pass through the less common colon separator (ITU Open Document Architecture) + #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline + #we will accept and pass through the less common colon separator (ITU Open Document Architecture) #Terminals should generally ignore it if they don't use it regexp {\033\[[0-9;:]*m$} $code } @@ -3618,7 +4450,7 @@ tcl::namespace::eval punk::ansi { return 1 } } - return 0 + return 0 } #pure SGR reset with no other functions proc is_sgr_reset {code} { @@ -3626,8 +4458,8 @@ tcl::namespace::eval punk::ansi { #[call [fun is_sgr_reset] [arg code]] #[para]Return a boolean indicating whether this string has a trailing pure SGR reset #[para]Note that if the reset is not the very last item in the string - it will not be detected. - #[para]This is primarily intended for testing a single ansi code sequence, but code can be any string where the trailing SGR code is to be tested. - + #[para]This is primarily intended for testing a single ansi code sequence, but code can be any string where the trailing SGR code is to be tested. + #todo 8-bit csi regexp {\x1b\[0*m$} $code } @@ -3637,7 +4469,7 @@ tcl::namespace::eval punk::ansi { #if an SGR code has a reset in it - we don't need to carry forward any previous SGR codes #it generally only makes sense for the reset to be the first parameter - otherwise the code has ineffective portions #However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params. - #We only look at the initial parameter within the trailing SGR code as this is the well-formed normal case. + #We only look at the initial parameter within the trailing SGR code as this is the well-formed normal case. #Review - consider normalizing sgr codes to remove other redundancies such as setting fg or bg colour twice in same code proc has_sgr_leadingreset {code} { @@ -3645,7 +4477,7 @@ tcl::namespace::eval punk::ansi { #[call [fun has_sgr_leadingreset] [arg code]] #[para]The reset must be the very first item in code to be detected. Trailing strings/codes ignored. set params "" - #we need non-greedy + #we need non-greedy if {[regexp {^\033\[([^m]*)m} $code _match params]} { #must match trailing m to be the type of reset we're looking for set plist [split $params ";"] @@ -3674,7 +4506,7 @@ tcl::namespace::eval punk::ansi { #regexp {\x1b\(B|\x1b\)B} $code regexp {\x1b(?:\(B|\)B)} $code } - #input assumed to be single codes - simple test for 2nd char left bracket and trailing m is done anyway - codes not matching are ignored and passed through + #input assumed to be single codes - simple test for 2nd char left bracket and trailing m is done anyway - codes not matching are ignored and passed through #This is not order-preserving if non-sgr codes are present as they are tacked on to the end even if they initially were before all SGR codes variable codestate_empty @@ -3682,11 +4514,11 @@ tcl::namespace::eval punk::ansi { 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 italic "" ;#3 on 23 off - tcl::dict::set codestate_empty underline "" ;#4 on 24 off + tcl::dict::set codestate_empty underline "" ;#4 on 24 off #nonstandard/extended 4:0,4:1,4:2,4:3,4:4,4:5 #4:1 single underline and 4:2 double underline deliberately kept separate to standard SGR versions - #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines + #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines tcl::dict::set codestate_empty underextended "" ;#4:0 for no extended underline 4:1 etc for underline styles #tcl::dict::set codestate_empty undersingle "" #tcl::dict::set codestate_empty underdouble "" @@ -3718,10 +4550,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty superscript "" ;#73 tcl::dict::set codestate_empty subscript "" ;#74 tcl::dict::set codestate_empty nosupersub "" ;#75 - # -- + # -- tcl::dict::set codestate_empty fg "" ;#30-37 + 90-97 - tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 + tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 #misnomer should have been sgr_merge_args ? :/ @@ -3730,15 +4562,16 @@ tcl::namespace::eval punk::ansi { if {[llength $args] == 0} { return "" } elseif {[llength $args] == 1} { - return [lindex $args 0] + return [lindex $args 0] } sgr_merge $args } proc sgr_merge {codelist args} { set allparts [list] foreach c $codelist { - set cparts [punk::ansi::ta::split_codes_single $c] - lappend allparts {*}[lsearch -all -inline -not $cparts ""] + #set cparts [punk::ansi::ta::split_codes_single $c] + #lappend allparts {*}[lsearch -all -inline -not $cparts ""] + lappend allparts {*}[punk::ansi::ta::get_codes_single $c] } sgr_merge_singles $allparts {*}$args } @@ -3748,6 +4581,7 @@ tcl::namespace::eval punk::ansi { -filter_fg 0\ -filter_bg 0\ -filter_reset 0\ + -info 0\ ] #codes *must* already have been split so that one esc per element in codelist @@ -3760,7 +4594,8 @@ tcl::namespace::eval punk::ansi { set opts $defaultopts_sgr_merge_singles foreach {k v} $args { switch -- $k { - -filter_fg - -filter_bg - -filter_reset { + -filter_fg - -filter_bg - -filter_reset - + -info { tcl::dict::set opts $k $v } default { @@ -3775,7 +4610,7 @@ tcl::namespace::eval punk::ansi { set did_reset 0 #we should also handle 8bit CSI here? mixed \x1b\[ and \x9b ? Which should be used in the merged result? - #There are arguments to move to 8bit CSI for keyboard protocols (to solve keypress timing issues?) - but does this extend to SGR codes? + #There are arguments to move to 8bit CSI for keyboard protocols (to solve keypress timing issues?) - but does this extend to SGR codes? #we will output 7bit merge of the SGRs even if some or all were 8bit CSi #As at 2024 - 7bit are widely supported 8bit seem to be often ignored by pseudoterminals #auto-detecting and emitting 8bit only if any are present in our input doesn't seem like a good idea - as sgr_merge_list is only seeing a subset of the data - so any auto-decision at this level will just introduce indeterminism. @@ -3809,10 +4644,10 @@ tcl::namespace::eval punk::ansi { #some codes have additional parameters - e.g rgb colours so we need to jump forward in the parameter list sometimes. for {set i 0} {$i < [llength $plist]} {incr i} { set p [lindex $plist $i] - set paramsplit [split $p :] - #for some cases we passthrough $p instead of just the number - in case another implementation uses the colon subparameters + set paramsplit [split $p :] + #for some cases we passthrough $p instead of just the number - in case another implementation uses the colon subparameters #e.g see https://github.com/mintty/mintty/wiki/Tips#text-attributes-and-rendering - #this may have originated with kitty? + #this may have originated with kitty? #windows terminal seems to be implementing it too #however, they can be completely repurposed - so we probably need to specifically support them.. REVIEW. @@ -3845,8 +4680,9 @@ tcl::namespace::eval punk::ansi { } 4 { #REVIEW - merging extended (e.g 4:4) underline attributes suppresses all other SGR attributes on at least some terminals which don't support extended underlines + #e.g hyper on windows if {[llength $paramsplit] == 1} { - tcl::dict::set codestate underline 4 + tcl::dict::set codestate underline 4 } else { switch -- [lindex $paramsplit 1] { 0 { @@ -3855,10 +4691,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended } 1 { - tcl::dict::set codestate underextended 4:1 + tcl::dict::set codestate underextended 4:1 } 2 { - tcl::dict::set codestate underextended 4:2 + tcl::dict::set codestate underextended 4:2 } 3 { tcl::dict::set codestate underextended "4:3" @@ -3880,7 +4716,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate reverse 7 } 8 { - tcl::dict::set codestate hide 8 + tcl::dict::set codestate hide 8 } 9 { tcl::dict::set codestate strike 9 @@ -3902,7 +4738,7 @@ tcl::namespace::eval punk::ansi { } 23 { #? wikipedia mentions blackletter - review - tcl::dict::set codestate italic 23 + tcl::dict::set codestate italic 23 } 24 { tcl::dict::set codestate underline 24 ;#off @@ -3930,11 +4766,11 @@ tcl::namespace::eval punk::ansi { 38 { #256 colour or rgb #check if subparams supplied as colon separated - if {[tcl::string::first : $p] < 0} { + if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate fg "38\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate fg "38\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -3944,9 +4780,9 @@ tcl::namespace::eval punk::ansi { } } } else { - #apparently subparameters can be left empty - and there are other subparams like transparency and colour-space + #apparently subparameters can be left empty - and there are other subparams like transparency and colour-space #we should only need to pass it all through for the terminal to understand - #review + #review tcl::dict::set codestate fg $p } } @@ -3962,7 +4798,7 @@ tcl::namespace::eval punk::ansi { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate bg "48\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate bg "48\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -3982,7 +4818,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate proportional 50 ;#off - see 26 } 51 - 52 { - tcl::dict::set codestate frame_or_circle 51 + tcl::dict::set codestate frame_or_circle 51 } 53 { tcl::dict::set codestate overline 53 ;#not supported in terminals? pass through anyway @@ -3994,13 +4830,13 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate overline 55; #off } 58 { - #nonstandard + #nonstandard #256 colour or rgb if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4069,11 +4905,11 @@ tcl::namespace::eval punk::ansi { } } - } + } default { lappend othercodes $c } - } + } } @@ -4084,7 +4920,7 @@ tcl::namespace::eval punk::ansi { #dict for {k v} $codestate {} tcl::dict::for {k v} $codestate { switch -- $v { - "" { + "" { } default { switch -- $k { @@ -4139,19 +4975,24 @@ tcl::namespace::eval punk::ansi { set codemerge [tcl::string::trimright $codemerge {;}] if {$unmergeable ne ""} { set unmergeable [tcl::string::trimright $unmergeable {;}] - return "\x1b\[${codemerge}m\x1b\[${unmergeable}m[join $othercodes ""]" + set mergeresult "\x1b\[${codemerge}m\x1b\[${unmergeable}m[join $othercodes ""]" } else { - return "\x1b\[${codemerge}m[join $othercodes ""]" + set mergeresult "\x1b\[${codemerge}m[join $othercodes ""]" } } else { if {$unmergeable eq ""} { #there were no SGR codes - not even resets - return [join $othercodes ""] + set mergeresult [join $othercodes ""] } else { set unmergeable [tcl::string::trimright $unmergeable {;}] - return "\x1b\[${unmergeable}m[join $othercodes ""]" + set mergeresult "\x1b\[${unmergeable}m[join $othercodes ""]" } } + if {[tcl::dict::get $opts -info]} { + return [dict create sgr $codemerge unmergeable $unmergeable othercodes $othercodes mergeresult $mergeresult codestate $codestate] + } else { + return $mergeresult + } } #has_sgr_reset - rather than support this function - create an sgr normalize function that removes dead params and brings reset to front of param list? @@ -4187,13 +5028,15 @@ tcl::namespace::eval punk::ansi { tcl::namespace::eval punk::ansi::ta { #*** !doctools #[subsection {Namespace punk::ansi::ta}] - #[para] text ansi functions + #[para] text ansi functions #[para] based on but not identical to the Perl Text Ansi module: #[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm #[list_begin definitions] tcl::namespace::path ::punk::ansi - #handle both 7-bit and 8-bit csi + variable PUNKARGS + + #handle both 7-bit and 8-bit csi #review - does codepage affect this? e.g ebcdic has 8bit csi in different position #CSI @@ -4215,13 +5058,19 @@ tcl::namespace::eval punk::ansi::ta { #non-greedy by excluding ST terminators variable re_esc_osc1 {(?:\x1b\])(?:[^\007]*)\007} #variable re_esc_osc2 {(?:\033\])(?:[^\033]*)\033\\} ;#somewhat wrong - we want to exclude the ST - not other esc sequences - variable re_esc_osc2 {(?:\x1b\])(?:(?!\x1b\\).)*\x1b\\} + variable re_esc_osc2 {(?:\x1b\])(?:(?!\x1b\\).)*\x1b\\} variable re_esc_osc3 {(?:\u009d)(?:[^\u009c]*)?\u009c} variable re_osc_open {(?:\x1b\]|\u009d).*} - variable standalone_code_map [list \x1bc "" \x1b7 "" \x1b8 "" \x1bM "" \x1bE "" \x1bD "" \x1bH "" \x1b= "" \x1b> "" \x1b#3 "" \x1b#4 "" \x1b#5 "" \x1b#6 "" \x1b#8 ""] - variable re_standalones {(?:\x1bc|\x1b7|\x1b8|\x1bM|\x1bE|\x1bD|\x1bD|\x1bH|\x1b=|\x1b>|\x1b#3|\x1b#4|\x1b#5|\x1b#6|\x1b#8)} + #variable standalone_code_map [list \x1bc "" \x1b7 "" \x1b8 "" \x1bM "" \x1bE "" \x1bD "" \x1bH "" \x1b= "" \x1b> "" \x1b#3 "" \x1b#4 "" \x1b#5 "" \x1b#6 "" \x1b#8 ""] + variable re_standalones {(?:\x1bc|\x1b7|\x1b8|\x1bM|\x1bD|\x1bE|\x1bH|\x1b=|\x1b>|\x1b#3|\x1b#4|\x1b#5|\x1b#6|\x1b#8)} + variable re_standalones_vt52 {(?:\x1bZ)} + + #ESC Y move, ESC b foreground colour + #ESC F - gr-on ESC G - gr-off + variable re_vt52_open {(?:\x1bY|\x1bb|\x1bF)} + #\x1bc vt52 bgcolour conflict ?? #if we don't split on altgraphics too and separate them out - it's easy to get into a horrible mess variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} @@ -4229,18 +5078,18 @@ tcl::namespace::eval punk::ansi::ta { variable re_g0_close {(?:\x1b\(B)} # DCS "ESC P" or "0x90" is also terminated by ST - set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} #ST terminators [list \007 \033\\ \u009c] #regex to capture the start of string/privacy message/application command block including the contents and string terminator (ST) #non-greedy by exclusion of ST terminators in body - #we need to match \x1b\\ not just \x1b There could be colour codes nested in a privacy msg/string + #we need to match \x1b\\ not just \x1b There could be colour codes nested in a privacy msg/string (not widely supported?) #even if terminals generally don't support that - it's quite possible for an ansi code to get nested this way - and we'd prefer it not to break our splits #Just checking for \x1b will terminate the match too early #we also need to track the start of ST terminated code and not add it for replay (in the ansistring functions) - #variable re_ST {(?:\x1bX|\u0098|\x1b\^|\u009E|\x1b_|\u009F)(?:[^\x1b\007\u009c]*)(?:\x1b\\|\007|\u009c)} ;#downsides: early terminating with nests, mixes 7bit 8bit start/ends (does that exist in the wild?) + #variable re_ST {(?:\x1bX|\u0098|\x1b\^|\u009E|\x1b_|\u009F)(?:[^\x1b\007\u009c]*)(?:\x1b\\|\007|\u009c)} ;#downsides: early terminating with nests, mixes 7bit 8bit start/ends (does that exist in the wild?) #keep our 8bit/7bit start-end codes separate - variable re_ST {(?:\x1bP|\x1bX|\x1b\^|\x1b_)(?:(?!\x1b\\|007).)*(?:\x1b\\|\007)|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)} + variable re_ST {(?:\x1bP|\x1bX|\x1b\^|\x1b_)(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007)|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)} @@ -4250,36 +5099,80 @@ tcl::namespace::eval punk::ansi::ta { # -- --- --- --- variable re_ansi_detect1 "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" # -- --- --- --- - #handrafted TRIE version of above. Somewhat difficult to construct and maintain. TODO - find a regext TRIE generator that works with Tcl regexes + #handrafted TRIE version of above. Somewhat difficult to construct and maintain. TODO - find a regexp TRIE generator that works with Tcl regexes #This does make things quicker - but it's too early to finalise the detect/split regexes (e.g missing \U0090 ) - will need to be redone. - variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} + #variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} + + #NOTE - the literal # char can cause problems in expanded syntax - even though it's within a bracketed section. \# seems to work though. + #vt52 specific |<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.)| + #https://freemint.github.io/tos.hyp/en/VT_52_terminal.html + #what to with ESC c vs vt52 ESC c (background colour) ??? + #we probably need to use a separate re_ansi_detect for vt52 + + #although it's stated later terminals are backwards compatible with vt52 - that doesn't seem to mean for example a vt100 will process vt52 codes at the same time as ansi codes + #ie - when DECANM is on - VT52 codes are *not* processed + + #todo - ansi mode and cursor key mode set ? + # arrow keys -> ESC O A, ESC O B, ESC O C, ESC O D + # plus more for auxiliary keypad codes in keypad application mode (and some in numeric mode) + + #regexp expanded syntax = ?x + variable re_ansi_detect {(?x) + (?:\x1b(?:\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|c|7|8|M|D|E|H|=|>|<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.))|\((?:0|B)|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|(?:\#(?:3|4|5|6|8)))) + |(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c) + |(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e] + |(?:\u009d)(?:[^\u009c]*)?\u009c + } + #--- + # -- --- --- --- + #variable re_csi_code {(?:\x1b\[|\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]} - variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_standalones}|${re_ST_open}|${re_g0_open}" - + variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_standalones}|${re_standalones_vt52}|${re_ST_open}|${re_g0_open}|${re_vt52_open}" + #may be same as detect - kept in case detect needs to diverge #variable re_ansi_split "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" set re_ansi_split $re_ansi_detect + variable re_ansi_split_multi + if {[string first (?x) $re_ansi_split] == 0} { + set re_ansi_split_multi "(?x)(?:[string range ${re_ansi_split} 4 end])+" + } else { + set re_ansi_split_multi "(?:${re_ansi_split})+" + } + + lappend PUNKARGS [list -dynamic 0 { + @id -id ::punk::ansi::ta::detect + @cmd -name punk::ansi::ta::detect -help\ + "Return a boolean indicating whether Ansi codes were detected in text. + Important caveat: + When text is a tcl list made from splitting (or lappending) some ansi string + - individual elements may be braced or have certain chars escaped. + (one example is if a list element contains an unbalanced brace) + This can cause square brackets that form part of the ansi to be backslash escaped + - and the function can fail to match it as an Ansi code. + " + @values -min 1 + text -type string + } ] + + #*** !doctools + #[call [fun detect] [arg text]] + #[para]Return a boolean indicating whether Ansi codes were detected in text + #[para]Important caveat: + #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) + #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match #detect any ansi escapes #review - only detect 'complete' codes - or just use the opening escapes for performance? proc detect {text} [string map [list [list $re_ansi_detect]] { - #*** !doctools - #[call [fun detect] [arg text]] - #[para]Return a boolean indicating whether Ansi codes were detected in text - #[para]Important caveat: - #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) - #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match regexp $text }] #can be used on dicts - but will check keys too. keys could also contain ansi and have escapes proc detect_in_list {list} { - detect [join $list " "] - } - proc detect_in_list2 {list} { + #loop is commonly faster than using join. (certain ansi codes triggering list quoting? review) foreach item $list { if {[detect $item]} { return 1 @@ -4287,11 +5180,16 @@ tcl::namespace::eval punk::ansi::ta { } return 0 } + #surprisingly - the ::join operation can be (relatively) slow on lists containing ansi + proc detect_in_list2 {list} { + detect [join $list " "] + } + proc detect_g0 {text} [string map [list [list $re_g0_group]] { regexp $text }] - #note - micro optimisation of inlining gives us *almost* nothing extra. - #left in place for a few such as detect/detect_g0 as we want them as fast as possible + #note - micro optimisation of inlining gives us *almost* nothing extra. + #left in place for a few such as detect/detect_g0 as we want them as fast as possible # in general the technique doesn't seem particularly worthwhile for this set of functions. #the performance is dominated by the complexity of the regexp proc detect2 {text} { @@ -4303,6 +5201,10 @@ tcl::namespace::eval punk::ansi::ta { variable re_ansi_detect_open expr {[regexp $re_ansi_detect_open $text]} } + proc detect_st_open {text} { + variable re_ST_open + expr {[regexp $re_ST_open $text]} + } #not in perl ta proc detect_csi {text} { @@ -4310,8 +5212,8 @@ tcl::namespace::eval punk::ansi::ta { #[call [fun detect_csi] [arg text]] #[para]Return a boolean indicating whether an Ansi Control Sequence Introducer (CSI) was detected in text #[para]The csi is often represented in code as \x1b or \033 followed by a left bracket [lb] - #[para]The initial byte or escape is commonly referenced as ESC in Ansi documentation - #[para]There is also a multi-byte escape sequence \u009b + #[para]The initial byte or escape is commonly referenced as ESC in Ansi documentation + #[para]There is also a multi-byte escape sequence \u009b #[para]This is less commonly used but is also detected here #[para](This function is not in perl ta) variable re_csi_open @@ -4339,7 +5241,7 @@ tcl::namespace::eval punk::ansi::ta { #*** !doctools #[call [fun length] [arg text]] #[para]Return the character length after stripping ansi codes - not the printing length - + #we can use ansistripraw to avoid g0 conversion - as the length should remain the same tcl::string::length [ansistripraw $text] } @@ -4358,11 +5260,11 @@ tcl::namespace::eval punk::ansi::ta { proc split_at_codes {str} [string map [list $re_ansi_split] { #variable re_ansi_split #punk::ansi::internal::splitx $str ${re_ansi_split} - punk::ansi::ta::Do_split_at_codes $str {} + punk::ansi::ta::Do_split_at_codes $str {} }] #it is faster to split this function out than to inline it into split_at_codes in tcl 8.7 - something to do with the use of the variable vs argument for the regexp #literal inlining of the re in the main proc-body was slower too - but inlining it into the wrapper seems to work (a tiny bit) - #the difference is not often apparent when comparing timerate results from split_at_codes vs split_at_codes2 - + #the difference is not often apparent when comparing timerate results from split_at_codes vs split_at_codes2 - # - but in aggregate for something like textblock::periodic - we can get a bit over 5% faster (e.g 136ms vs 149ms) proc Do_split_at_codes {str regexp} { if {$str eq ""} { @@ -4441,123 +5343,160 @@ tcl::namespace::eval punk::ansi::ta { lappend list [tcl::string::range $str $start end] return $list }] - - # -- --- --- --- --- --- + + # -- --- --- --- --- --- #Split $text to a list containing alternating ANSI colour codes and text. #ANSI colour codes are always on the second element, fourth, and so on. - #(ie plaintext on odd list-indices ansi on even indices) + #(ie plaintext on even list-indices ansi on odd indices) + #result of split on non-empty string always has an odd length - with indices 0 and end always being plaintext (possibly empty string) # Example: - #ta_split_codes "" # => "" - #ta_split_codes "a" # => "a" - #ta_split_codes "a\e[31m" # => {"a" "\e[31m"} - #ta_split_codes "\e[31ma" # => {"" "\e[31m" "a"} - #ta_split_codes "\e[31ma\e[0m" # => {"" "\e[31m" "a" "\e[0m"} - #ta_split_codes "\e[31ma\e[0mb" # => {"" "\e[31m" "a" "\e[0m", "b"} - #ta_split_codes "\e[31m\e[0mb" # => {"" "\e[31m\e[0m" "b"} + #split_codes "" # => "" + #split_codes "a" # => "a" + #split_codes "a\e[31m" # => {"a" "\e[31m" ""} + #split_codes "\e[31ma" # => {"" "\e[31m" "a"} + #split_codes "\e[31ma\e[0m" # => {"" "\e[31m" "a" "\e[0m" ""} + #split_codes "\e[31ma\e[0mb" # => {"" "\e[31m" "a" "\e[0m", "b"} + #split_codes "\e[31m\e[0mb" # => {"" "\e[31m\e[0m" "b"} # proc split_codes {text} { - variable re_ansi_split - set re "(?:${re_ansi_split})+" - return [_perlish_split $re $text] + variable re_ansi_split_multi + return [_perlish_split $re_ansi_split_multi $text] } - #micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds) + #micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds) - #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds) + #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so even/odd indices for plain ansi still holds) #- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped. proc split_codes_single {text} { + if {$text eq ""} { + return {} + } + variable re_ansi_split + set next 0 + #set b -1 + set list [list] + set coderanges [regexp -indices -all -inline -- $re_ansi_split $text] + foreach cr $coderanges { + lappend list [tcl::string::range $text $next [lindex $cr 0]-1] [tcl::string::range $text [lindex $cr 0] [lindex $cr 1]] + set next [expr {[lindex $cr 1]+1}] + #set next [lindex $cr 1]+1 ;#text index-expression for string range + } + lappend list [tcl::string::range $text $next end] + return $list + } + proc split_codes_single2 {text} { variable re_ansi_split return [_perlish_split $re_ansi_split $text] } + proc get_codes_single {text} { + variable re_ansi_split + regexp -all -inline -- $re_ansi_split $text + } #review - tcl greedy expressions may match multiple in one element proc _perlish_split {re text} { + if {$text eq ""} { + return {} + } + set next 0 + #set b -1 + set list [list] + set coderanges [regexp -indices -all -inline -- $re $text] + foreach cr $coderanges { + lappend list [tcl::string::range $text $next [lindex $cr 0]-1] [tcl::string::range $text [lindex $cr 0] [lindex $cr 1]] + set next [expr {[lindex $cr 1]+1}] + } + lappend list [tcl::string::range $text $next end] + return $list + } + proc _perlish_split2 {re text} { if {$text eq ""} { return {} } set list [list] set start 0 - + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW while {[regexp -start $start -indices -- $re $text match]} { lassign $match matchStart matchEnd #puts "->start $start ->match $matchStart $matchEnd" if {$matchEnd < $matchStart} { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::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 $matchStart] + incr start + } else { + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + set start [expr {$matchEnd+1}] } - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] - set start [expr {$matchEnd+1}] - #? if {$start >= [tcl::string::length $text]} { break } } return [lappend list [tcl::string::range $text $start end]] } - - #experiment for coroutine generator - proc _perlish_split_yield {re text} { - if {[tcl::string::length $text] == 0} { - yield {} + proc _perlish_split3 {re text} { + if {$text eq ""} { + return {} } set list [list] set start 0 - + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW while {[regexp -start $start -indices -- $re $text match]} { lassign $match matchStart matchEnd #puts "->start $start ->match $matchStart $matchEnd" if {$matchEnd < $matchStart} { - yield [tcl::string::range $text $start $matchStart-1] - yield [tcl::string::index $text $matchStart] - incr start + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start if {$start >= [tcl::string::length $text]} { break } continue } - yield [tcl::string::range $text $start $matchStart-1] - yield [tcl::string::range $text $matchStart $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] #? if {$start >= [tcl::string::length $text]} { break } } - #return [lappend list [tcl::string::range $text $start end]] - yield [tcl::string::range $text $start end] + return [lappend list [tcl::string::range $text $start end]] } - proc _perlish_split2 {re text} { + + #experiment for coroutine generator + proc _perlish_split_yield {re text} { if {[tcl::string::length $text] == 0} { - return {} + yield {} } set list [list] set start 0 + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW while {[regexp -start $start -indices -- $re $text match]} { lassign $match matchStart matchEnd #puts "->start $start ->match $matchStart $matchEnd" if {$matchEnd < $matchStart} { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] - incr start - } else { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] - set start [expr {$matchEnd+1}] + yield [tcl::string::range $text $start $matchStart-1] + yield [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue } + yield [tcl::string::range $text $start $matchStart-1] + yield [tcl::string::range $text $matchStart $matchEnd] + set start [expr {$matchEnd+1}] + #? if {$start >= [tcl::string::length $text]} { break } } - return [lappend list [tcl::string::range $text $start end]] + #return [lappend list [tcl::string::range $text $start end]] + yield [tcl::string::range $text $start end] } proc _ws_split {text} { regexp -all -inline {(?:\S+)|(?:\s+)} $text } - # -- --- --- --- --- --- + # -- --- --- --- --- --- #*** !doctools #[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}] @@ -4577,7 +5516,8 @@ tcl::namespace::eval punk::ansi::class { } oo::class create base_renderer { variable o_width - variable o_wrap o_overflow o_appendlines o_looplimit + variable o_autowrap_mode + variable o_overflow o_appendlines o_looplimit variable o_cursor_column o_cursor_row #variable o_render_index ;#index of input (from_ansistring) grapheme/ansi-code that *has* been rendered @@ -4593,27 +5533,35 @@ tcl::namespace::eval punk::ansi::class { if {"::punk::ansi::class" ni $nspath} { lappend nspath ::punk::ansi::class } - tcl::namespace::path $nspath + tcl::namespace::path $nspath #-- -- - if {[llength $args] < 2} { - error {usage: ?-width ? ?-wrap [1|0]? ?-overflow [1|0]? from_ansistring to_ansistring} + if {[llength $args] < 1} { + error {usage: ?-width ? ?-height ? ?-autowrap_mode [1|0]? ?-overflow [1|0]? from_ansistring} } - lassign [lrange $args end-1 end] from_ansistring to_ansistring + #lassign [lrange $args end-1 end] from_ansistring to_ansistring + set from_ansistring [lindex $args end] + set opts [tcl::dict::create\ - -width \uFFEF\ - -wrap 1\ - -overflow 0\ - -appendlines 1\ - -looplimit 15000\ - -experimental {}\ - -cursor_column 1\ - -cursor_row 1\ + -width \uFFEF\ + -height \uFFEF\ + -overflow 0\ + -appendlines 1\ + -looplimit 15000\ + -experimental {}\ + -cursor_column 1\ + -cursor_row 1\ + -insert_mode 0\ + -autowrap_mode 1\ + -initial_ansistring ""\ ] - puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring" set argsflags [lrange $args 0 end-2] foreach {k v} $argsflags { switch -- $k { - -width - -wrap - -overflow - -appendlines - -looplimit - -experimental { + -width - -height - + -overflow - -appendlines - -looplimit - -experimental - + -autowrap_mode - + -insert_mode - + -initial_ansistring { tcl::dict::set opts $k $v } default { @@ -4622,8 +5570,19 @@ tcl::namespace::eval punk::ansi::class { } } } + set initial_ansistring [tcl::dict::get $opts -initial_ansistring] + if {$initial_ansistring eq ""} { + set to_ansistring [punk::ansi::class::class_ansistring new ""] + } else { + #todo - verify obj vs raw string + set to_ansistring $initial_ansistring + } + puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring" + set o_width [tcl::dict::get $opts -width] - set o_wrap [tcl::dict::get $opts -wrap] + set o_height [tcl::dict::get $opts -height] + set o_autowrap_mode [tcl::dict::get $opts -autowrap_mode] + set o_insert_mode [tcl::dict::get $opts -insert_mode] set o_overflow [tcl::dict::get $opts -overflow] set o_appendlines [tcl::dict::get $opts -appendlines] set o_looplimit [tcl::dict::get $opts -looplimit] @@ -4641,6 +5600,9 @@ tcl::namespace::eval punk::ansi::class { method eval_in {script} { eval $script } + method renderbuf {} { + return $o_to_ansistring + } method cursor_column {{col ""}} { if {$col eq ""} { return $o_cursor_column @@ -4660,12 +5622,18 @@ tcl::namespace::eval punk::ansi::class { set o_cursor_row $row } + #set/query cursor state + method cursor_state {args} { + lassign $args r c + return [dict create row [my cursor_row $r] column [my cursor_column $c]] + } + #consider scroll area #we need to render to something with a concept of viewport, offscreen above,below,left,right? method rendernext {} { upvar ${o_ns_from}::o_ansisplits from_ansisplits upvar ${o_ns_from}::o_elements from_elements - upvar ${o_ns_from}::o_splitindex from_splitindex + upvar ${o_ns_from}::o_splitindex from_splitindex #if {![llength $from_ansisplits]} {$o_from_ansistring eval_in {my MakeSplit}} ;#!!todo - a better way to keep this method semi hidden but call from a 'friend' if {![llength $from_ansisplits]} { @@ -4691,7 +5659,7 @@ tcl::namespace::eval punk::ansi::class { set process_splitindex [lindex $from_splitindex $eidx] ;#which from_ansisplits index the first unrendered element belongs to set elementinfo [lindex $from_elements $eidx] - lassign $elementinfo type_rendered item + lassign $elementinfo type_rendered item #we don't expect type to change should be all graphemes (type 'g') or a single code (type 'sgr','other' etc) #review - we may want to store more info for graphemes e.g g0 g1 g2 for zero-wide 1-wide 2-wide ? #if so - we should report a list of the grapheme types that were rendered in a pt block @@ -4707,7 +5675,7 @@ tcl::namespace::eval punk::ansi::class { set e_splitindex $process_splitindex while {$e_splitindex == $process_splitindex && $eidx < [llength $from_elements]} { append newtext $item - lappend o_rendereditems $elementinfo + lappend o_rendereditems $elementinfo incr rendercount incr eidx @@ -4717,8 +5685,8 @@ tcl::namespace::eval punk::ansi::class { } } else { #while not g ? render however many ansi sequences are in a row? - set newtext $item - lappend o_rendereditems $elementinfo + set newtext $item + lappend o_rendereditems $elementinfo incr rendercount } @@ -4736,17 +5704,18 @@ tcl::namespace::eval punk::ansi::class { if {![tcl::string::length $overtext]} { continue } - #set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext] + #set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext] } } - + #renderspace equivalent? channel based? + #todo $o_to_ansistring append $newtext return [tcl::dict::create type $type_rendered rendercount $rendercount start_count_unrendered $start_elements_unrendered end_count_unrendered $end_elements_unrendered] } } - #name all with prefix class_ for rendertype detection + #name all with prefix class_ for rendertype detection oo::class create class_cp437 { superclass base_renderer } @@ -4765,7 +5734,7 @@ tcl::namespace::eval punk::ansi::class { #this is the main state we keep of the split apart string #we use the punk::ansi::ta::split_codes_single function which produces a list with zero, or an odd number elements always beginning and ending with plaintext - variable o_ptlist ;#plaintext as list of elements from ansisplits - will include empty elements from between adjacent ansi-codes + variable o_ptlist ;#plaintext as list of elements from ansisplits - will include empty elements from between adjacent ansi-codes variable o_ansisplits ;#store our plaintext/ansi-code splits so we don't keep re-running the regexp to split @@ -4782,7 +5751,7 @@ tcl::namespace::eval punk::ansi::class { variable o_elements ;#elements contains entry for each grapheme/control + each ansi code variable o_sgrstacks ;#list of ansi sgr codes that will be merged later. Entries deliberately repeat if no change from previous entry. Later scans look for difference between n and n-1 when deciding where to apply codes. variable o_gx0states ;#0|1 for alternate graphics gx0 - variable o_splitindex ;#entry for each element indicating the index of the split it belongs to. + variable o_splitindex ;#entry for each element indicating the index of the split it belongs to. # -- -- constructor {string} { @@ -4795,7 +5764,7 @@ tcl::namespace::eval punk::ansi::class { if {"::punk::ansi::class" ni $nspath} { lappend nspath ::punk::ansi::class } - tcl::namespace::path $nspath + tcl::namespace::path $nspath #-- -- #we choose not to generate an internal split-state for the initial string - which may potentially be large. @@ -4804,7 +5773,7 @@ tcl::namespace::eval punk::ansi::class { set o_count "" ;#o_count first updated when string appended or a method causes MakeSplit to run (or by count method if constructor argument was empty string) - set o_ansisplits [list] ;#we get empty pt(plaintext) between each ansi code. Codes include cursor movements, resets,alt graphics modes, terminal mode settings etc. + set o_ansisplits [list] ;#we get empty pt(plaintext) between each ansi code. Codes include cursor movements, resets,alt graphics modes, terminal mode settings etc. set o_ptlist [list] #o_ansisplits and o_ptlist should only remain empty if an empty string was passed to the contructor, or no methods have yet triggered the initial string to have it's internal state built. @@ -4818,7 +5787,7 @@ tcl::namespace::eval punk::ansi::class { #empty if no render methods used # -- - set o_renderer "" + set o_renderer "" set o_renderout "" ;#class_ansistring # -- @@ -4842,18 +5811,18 @@ tcl::namespace::eval punk::ansi::class { method show_state {{verbose 0}} { #show some state info - without updating anything - #only use 'my' methods that don't update the state e.g has_ansi + #only use 'my' methods that don't update the state e.g has_ansi set result "" if {![llength $o_ansisplits]} { append result "No internal splits. " append result \n "has ansi : [my has_ansi]" - append result \n "Tcl string length raw string: [tcl::string::length $o_string]" + append result \n "Tcl string length raw string: [tcl::string::length $o_string]" } else { append result \n "has ansi : [my has_ansi]" - append result \n "ansisplit list len: [llength $o_ansisplits]" + append result \n "ansisplit list len: [llength $o_ansisplits]" append result \n "plaintext list len: [llength $o_ptlist]" append result \n "cached count : $o_count" - append result \n "Tcl string length raw string : [tcl::string::length $o_string]" + append result \n "Tcl string length raw string : [tcl::string::length $o_string]" append result \n "Tcl string length plaintext parts: [tcl::string::length [join $o_ptlist ""]]" if {[llength $o_ansisplits] %2 == 0} { append result \n -------------------------------------------------- @@ -4865,11 +5834,10 @@ tcl::namespace::eval punk::ansi::class { if {$o_renderer ne ""} { append result \n " renderer obj: $o_renderer" append result \n " renderer class: [info object class $o_renderer]" - } - if {$o_renderout ne ""} { - append result \n " render target ansistring: $o_renderout" - append result \n " render target has ansi : [$o_renderout has_ansi]" - append result \n " render target count : [$o_renderout count]" + set renderstring [$o_renderer renderbuf] + append result \n " render target ansistring: $renderstring" + append result \n " render target has ansi : [$renderstring has_ansi]" + append result \n " render target count : [$renderstring count]" } if {$verbose} { append result \n "ansisplits listing" @@ -4893,10 +5861,10 @@ tcl::namespace::eval punk::ansi::class { #private method method MakeSplit {} { #The split with each code as it's own element is more generally useful. - set o_ansisplits [punk::ansi::ta::split_codes_single $o_string]; + set o_ansisplits [punk::ansi::ta::split_codes_single $o_string]; set o_ptlist [list] set codestack [list] - set gx0_state 0 ;#default off + set gx0_state 0 ;#default off set current_split_index 0 ;#incremented for each pt block, incremented for each code if {$o_count eq ""} { set o_count 0 @@ -4911,7 +5879,7 @@ tcl::namespace::eval punk::ansi::class { incr o_count } #after handling the pt block - incr the current_split_index - incr current_split_index ;#increment for each pt block - whether empty string or not. Indices corresponding to empty PT blocks will therefore not be present in o_splitindex as there were no elements in that ansisplit entry + incr current_split_index ;#increment for each pt block - whether empty string or not. Indices corresponding to empty PT blocks will therefore not be present in o_splitindex as there were no elements in that ansisplit entry #we will only get an empty code at the very end of ansisplits (ansisplits is length 0 or odd length - always with pt at start and pt at end) if {$code ne ""} { lappend o_sgrstacks $codestack @@ -4947,7 +5915,7 @@ tcl::namespace::eval punk::ansi::class { } } #assertion every grapheme and every individual code has been added to o_elements - #every element has an entry in o_sgrstacks + #every element has an entry in o_sgrstacks #every element has an entry in o_gx0states assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} } @@ -4957,7 +5925,8 @@ tcl::namespace::eval punk::ansi::class { } method strippedlength {} { if {![llength $o_ansisplits]} {my MakeSplit} - + #review + return [string length [join $o_ptlist ""]] } #returns the ansiless string - doesn't affect the stored state other than initialising it's internal state if it wasn't already method stripped {} { @@ -4966,16 +5935,17 @@ tcl::namespace::eval punk::ansi::class { } #does not affect object state + #REVIEW - icu or equiv required method DoCount {plaintext} { #- combiners/diacritics just map them away here - but for consistency we need to combine unicode grapheme clusters too. #todo - joiners 200d? zwnbsp - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - #we want length to return number of glyphs + normal controls such as newline.. not screen width. Has to be consistent with index function + #we want length to return number of glyphs + normal controls such as newline.. not screen width. Has to be consistent with index function return [tcl::string::length [regsub -all $re_diacritics $plaintext ""]] } - #This is the count of visible graphemes + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! + #This is the count of visible graphemes + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! method count {} { if {$o_count eq ""} { #only initial string present @@ -5008,7 +5978,7 @@ tcl::namespace::eval punk::ansi::class { #channels for stream in/out.. these are vaguely analogous to the input/output between a shell and a PTY Slave - but this is not intended to be a full pseudoterminal #renderstream_to_render (private?) - # write end held by outer ansistring? read end by inner render ansistring ? + # write end held by outer ansistring? read end by inner render ansistring ? #renderstream_from_render (public?) method rendertypes {} { @@ -5022,12 +5992,11 @@ tcl::namespace::eval punk::ansi::class { } set rtypes [my rendertypes] if {$rtype ni $rtypes} { - error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)" - } - if {$o_renderout eq ""} { - #tell ansistring that it's a renderbuf for another ansistring? point it to the renderer or the parent ansistring? - set o_renderout [punk::ansi::class::class_ansistring new ""] + error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)" } + #if {$o_renderout eq ""} { + # set o_renderout [punk::ansi::class::class_ansistring new ""] + #} if {$o_renderer ne ""} { set oinfo [info object class $o_renderer] set tail [tcl::namespace::tail $oinfo] @@ -5035,13 +6004,15 @@ tcl::namespace::eval punk::ansi::class { if {$rtype ne $currenttype} { puts "switch rendertype from $currenttype to $rtype - destroying renderer and creating a new one" $o_renderer destroy ;#what happens to data in target ansistring obj? when does it make sense to keep output and keep rendering vs clearing? - set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout] + #set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout] + set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]] } else { return $currenttype } } else { puts "creating first renderer" - set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout] + #set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout] + set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]] } } #--- progressive rendering buffer - another ansistring object @@ -5052,26 +6023,56 @@ tcl::namespace::eval punk::ansi::class { } if {$rw eq $o_renderwidth} { return $o_renderwidth - } + } #re-render if needed? - + puts stderr "renderwidth todo? re-render?" set o_renderwidth $rw } + method renderer {} { + return $o_renderer + } method render_state {} { #? report state of render.. we will primarily be using plaintext/ansisequence as the chunk/operation boundary #but - as we can append char sequences directly to the tail split - it's not enough to track which split element we have rendered - but we also need how many graphemes or code sequences we are into the last split. - #A single number representing the count of graphemes and individual ANSI codes (from the input ansistring) rendered might work + #A single number representing the count of graphemes and individual ANSI codes (from the input ansistring) rendered might work } method renderbuf {} { #get the underlying renderobj - if any - return $o_renderout ;#also class_ansistring + #return $o_renderout ;#also class_ansistring + if {$o_renderer eq ""} {error "renderbuf error: no active renderer"} + return [$o_renderer renderbuf] } - method render {} { + method render {{maxgraphemes ""}} { #full render - return buffer ansistring + set do_render 1 + set grapheme_count 0 + set other_count 0 + if {$maxgraphemes eq ""} { + while {$do_render} { + set rendition [my rendernext] + set do_render [dict get $rendition rendercount] + if {[dict get $rendition type] eq "g"} { + incr grapheme_count $do_render + } else { + incr other_count $do_render + } + } + } else { + while {$do_render && $grapheme_count <= $maxgraphemes} { + set rendition [my rendernext] + set do_render [dict get $rendition rendercount] + if {[dict get $rendition type] eq "g"} { + incr grapheme_count $do_render + } else { + incr other_count $do_render + } + } + } + return [dict create graphemes $grapheme_count other $other_count] } method rendernext {} { - #render next available pt/code chunk only - not to end of available input + #render next available pt/code chunk only - not to end of available input if {$o_renderer eq ""} { my rendertype $o_rendertype ;#review - proper way to initialise rendering } @@ -5103,8 +6104,15 @@ tcl::namespace::eval punk::ansi::class { #i.e a 'rendered' ANSI string should contain just ANSI SGR character attributes and linefeeds for rows #Knowing which is which can be helpful as far as use of any methods which use the concepts of terminal row/column + #like Tcl's append class_ansistring append returns the result directly - which for ANSI - can be inconvenient in the terminal + #class_ansistring append_string is a convenience wrapper to avoid returning the raw result + method append_string {args} { + my append {*}$args + return + } + #analagous to Tcl string append - #MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient + #MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient method append {args} { set catstr [join $args ""] if {$catstr eq ""} { @@ -5115,19 +6123,19 @@ tcl::namespace::eval punk::ansi::class { #ansi-free additions #if no initial internal-split - generate it without first appending our additions - as we can more efficiently append them to the internal state if {![llength $o_ansisplits]} { - #initialise o_count because we need to add to it. + #initialise o_count because we need to add to it. #The count method will do this by calling Makesplit only if it needs to. (which will create ansisplits for anything except empty string) my count } append o_string $catstr;# only append after updating using my count above if {![llength $o_ptlist]} { - #If the object was initialised with empty string - we can still have empty lists for o_ptlist and o_ansisplits + #If the object was initialised with empty string - we can still have empty lists for o_ptlist and o_ansisplits #even though we can use lset to add to a list - we can't for empty lappend o_ptlist $catstr #assertion - if o_ptlist is empty so is o_ansisplits lappend o_ansisplits $catstr } else { - lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] $catstr] + lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] $catstr] lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] $catstr] } set last_codestack [lindex $o_sgrstacks end] @@ -5149,16 +6157,16 @@ tcl::namespace::eval punk::ansi::class { #set combined_plaintext [join $o_ptlist ""] #set o_count [my DoCount $combined_plaintext] assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} - return $o_string + return $o_string } else { - #update each element of internal state incrementally without reprocessing what is already there. + #update each element of internal state incrementally without reprocessing what is already there. append o_string $catstr - set newsplits [punk::ansi::ta::split_codes_single $catstr] + set newsplits [punk::ansi::ta::split_codes_single $catstr] set ptnew "" set codestack [lindex $o_sgrstacks end] set gx0_state [lindex $o_gx0states end] - set current_split_index [lindex $o_splitindex end] - #first pt must be merged with last element of o_ptlist + set current_split_index [lindex $o_splitindex end] + #first pt must be merged with last element of o_ptlist set new_pt_list [list] foreach {pt code} $newsplits { lappend new_pt_list $pt @@ -5209,7 +6217,7 @@ tcl::namespace::eval punk::ansi::class { #if {$o_count eq ""} { # #we have splits - but didn't count graphemes? - # set o_count [my DoCount [join $o_ptlist ""]] ;#o_ptlist already has ptnew parts + # set o_count [my DoCount [join $o_ptlist ""]] ;#o_ptlist already has ptnew parts #} else { # incr o_count [my DoCount $ptnew] #} @@ -5220,7 +6228,7 @@ tcl::namespace::eval punk::ansi::class { return $o_string } - #we are currently assuming that the component strings have complete graphemes ie no split clusters - and therefore we don't attempt to check for and combine at the string catenation points. + #we are currently assuming that the component strings have complete graphemes ie no split clusters - and therefore we don't attempt to check for and combine at the string catenation points. #This is 'often'? likely to be true - We don't have grapheme cluster support yet anyway. review. method appendobj {args} { if {![llength $o_ansisplits]} { @@ -5265,7 +6273,7 @@ tcl::namespace::eval punk::ansi::class { set firstnewidx [lindex $new_splitindex 0] set diffidx [expr {$lastidx - $firstnewidx}] ;#may be negative foreach v $new_splitindex { - lappend o_splitindex [expr {$v + $diffidx}] + lappend o_splitindex [expr {$v + $diffidx}] } incr o_count $new_count @@ -5274,7 +6282,7 @@ tcl::namespace::eval punk::ansi::class { } - #method append_and_render - append and render up to end of appended data at same time + #method append_and_render? - append and render up to end of appended data at same time method view {args} { if {$o_string eq ""} { @@ -5316,7 +6324,7 @@ tcl::namespace::eval punk::ansi::class { set arrow_lr \u2194 set arrow_du \u2195 #2024 - there is no 4-arrow symbol or variations (common cursor and window icon) in unicode - despite requests and argument from the community that this has been in use for decades. - #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. + #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. #don't split into lines first - \n is valid within ST sections set output "" @@ -5331,7 +6339,7 @@ tcl::namespace::eval punk::ansi::class { set c1 [tcl::string::index $code 0] set c1c2 [tcl::string::range $code 0 1] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[ 7CSI\ \x9b 8CSI\ @@ -5339,9 +6347,9 @@ tcl::namespace::eval punk::ansi::class { \x1b\( 7GFX\ \x9d 8OSC\ \x1b 7ESC\ - ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars + ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - #we leave the tail of the code unmapped for now + #we leave the tail of the code unmapped for now switch -- $leadernorm { 7CSI - 7OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] @@ -5394,7 +6402,7 @@ tcl::namespace::eval punk::ansi::class { H - f { set params [tcl::string::range $codenorm 4 end-1] lassign [split $params {;}] row col - #lassign $matchinfo _match row col + #lassign $matchinfo _match row col set displaycode [ansistring VIEW $code] if {$col eq ""} { #row only move @@ -5416,7 +6424,7 @@ tcl::namespace::eval punk::ansi::class { append output ${unk}[ansistring VIEW -lf 1 $code]$RST } } - } + } 7GFX { switch -- [tcl::string::index $codenorm 4] { "0" { @@ -5449,7 +6457,7 @@ tcl::namespace::eval punk::ansi::class { #set splits [punk::ansi::ta::split_codes_single $string] set output "" set codestack [list] - set gx_stack [list] ;#not actually a stack + set gx_stack [list] ;#not actually a stack set cursor_saved "" foreach {pt code} $o_ansisplits { if {[llength $args]} { @@ -5475,13 +6483,13 @@ tcl::namespace::eval punk::ansi::class { #cursor_restore set codestack [list $cursor_saved] } else { - #leave SGR stack as is + #leave SGR stack as is if {[punk::ansi::codetype::is_gx_open $code]} { set gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess } elseif {[punk::ansi::codetype::is_gx_close $code]} { set gx_stack [list] - } - } + } + } } } return $output @@ -5493,24 +6501,24 @@ tcl::namespace::eval punk::ansi { proc stripansi3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { - #using detect costs us a couple of uS - but saves time on plain text + #using detect costs us a couple of uS - but saves time on plain text #we should probably leave this for caller - otherwise it ends up being called more than necessary - #if {![::punk::ansi::ta::detect $text]} { + #if {![::punk::ansi::ta::detect $text]} { # return $text #} #alternate graphics codes are not the norm - # - so save a few uS in the common case by only calling convert_g0 if we detect + # - so save a few uS in the common case by only calling convert_g0 if we detect if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } - punk::ansi::ta::Do_split_at_codes_join $text {} + punk::ansi::ta::Do_split_at_codes_join $text {} }] proc stripansiraw3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { #join [::punk::ansi::ta::split_at_codes $text] "" - punk::ansi::ta::Do_split_at_codes_join $text {} + punk::ansi::ta::Do_split_at_codes_join $text {} }] } @@ -5526,7 +6534,7 @@ tcl::namespace::eval punk::ansi::ansistring { tcl::namespace::ensemble create tcl::namespace::export length trim trimleft trimright INDEX COUNT VIEW VIEWCODES VIEWSTYLE INDEXABSOLUTE INDEXCOLUMNS COLUMNINDEX NEW #todo - expose _splits_ methods so caller can work efficiently with the splits themselves - #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single + #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single #\UFFFD - replacement char or \U2426 @@ -5640,7 +6648,7 @@ tcl::namespace::eval punk::ansi::ansistring { variable debug_visuals #modern (c0 seem to have more terminal/font support - C1 can show 8bit c1 codes - but also seems to be limited support) - + #Goal is not to map every control character? #Map of which elements we want to convert - done this way so we can see names of control's that are included: - ease of maintenance compared to just creating the tcl::string::map directly #ETX -ctrl-c @@ -5674,7 +6682,12 @@ tcl::namespace::eval punk::ansi::ansistring { ENQ [list \x05 \u2405]\ ACK [list \x06 \u2406]\ BEL [list \x07 \u2407]\ + BS [list \x08 \u2408]\ + HT [list \x09 \u2409]\ + LF [list \x0a \u240a]\ + VT [list \x0b \u240b]\ FF [list \x0c \u240c]\ + CR [list \x0d \u240d]\ SO [list \x0e \u240e]\ SF [list \x0f \u240f]\ DLE [list \x10 \u2410]\ @@ -5688,12 +6701,19 @@ tcl::namespace::eval punk::ansi::ansistring { CAN [list \x18 \u2418]\ EM [list \x19 \u2419]\ SUB [list \x1a \u241a]\ + ESC [list \x1b \u241b]\ FS [list \x1c \u241c]\ GS [list \x1d \u241d]\ RS [list \x1e \u241e]\ US [list \x1f \u241f]\ + SP [list \x20 \u2420]\ DEL [list \x7f \u2421]\ ] + set map_c0 [dict create] + dict for {k v} $visuals_c0 { + dict set map_c0 {*}$v + } + #alternate symbols for space # \u2422 Blank Symbol (b with forwardslash overly) # \u2423 Open Box (square bracket facing up like a tray/box) @@ -5710,10 +6730,10 @@ tcl::namespace::eval punk::ansi::ansistring { #we'll hack in some stuff as needed - may override some of the visuals_c1 which is usually just empty/substitute glyphs #Being repurposed - these could potentially be confused with actual characters depending on the debugging context #To minimize potential confusion - we'll use a longer replacement sequence - which is not ideal from the perspective of terminal column layout debugging - #A single unique glyph would be better - although the bracketing for 8-bit codes is a useful visual indicator + #A single unique glyph would be better - although the bracketing for 8-bit codes is a useful visual indicator #(review - BOM should use different brackets to c1?) - #todo - regularly check if unicode has improved in this area - though with requests for c1 visuals dating back to at least 2011 - it's doubtful. + #todo - regularly check if unicode has improved in this area - though with requests for c1 visuals dating back to at least 2011 - it's doubtful. #for 8-bit controls - we will standardize on a fixed width of 4 bracketing with: #\u2987 and \u2988 from Miscellaneous Mathematical Symbols-B (D or fractional-moon shaped brackets) #\u2987 - Z Notation Left Image Bracket @@ -5728,7 +6748,10 @@ tcl::namespace::eval punk::ansi::ansistring { #miscellaneous debug code brackets set obm \u27e6 ;set cbm \u27e7 ;#square double brackets from Miscellaneous Mathematical Symbols-A - #this private range so rarely supported in fonts - and visuals are unknown, so we will make up some 2-letter codes for now + #unicode Tags block brackets + set obt \u2993 ;set cbt \u2994 + + #this private range so rarely supported in fonts - and visuals are unknown, so we will make up some 2-letter codes for now #set visuals_c1 [tcl::dict::create\ # BPH [list \x82 "${ob8}\ue022 $cb8"]\ # NBH [list \x83 "${ob8}\ue023 $cb8"]\ @@ -5796,23 +6819,35 @@ tcl::namespace::eval punk::ansi::ansistring { PM [list \x9e "${ob8}PM$cb8"]\ APC [list \x9f "${ob8}AP$cb8"]\ ] - + + #unicode Tags block - nonprinting mapped to ascii 0-127 + set visuals_tags [tcl::dict::create] + for {set i 917504} {$i < 917632} {incr i} { + set asciidec [expr {$i - 917504}] + set vis [format %c $asciidec] + if {[dict exists $map_c0 $vis]} { + set vis [dict get $map_c0 $vis] + } + tcl::dict::set visuals_tags TAG$asciidec [list [format %c $i] "${obt}$vis${cbt}"] + } + set hack [tcl::dict::create] tcl::dict::set hack BOM1 [list \uFEFF "${obm}\U1f4a3$cbm"] ;#byte order mark/ ZWNBSP (ZWNBSP usage generally deprecated) - a picture of a bomb(2wide glyph) + tcl::dict::set hack ZWSP [list \u200B "${obm}ZWSP$cbm"] #review - other boms? Encoding dependent? tcl::dict::set hack DCS [list \x90 "${ob8}\u2328 $cb8"] ;#keyboard from Miscellaneous Technical - 1 wide + pad. tcl::dict::set hack SOS [list \x98 "${ob8}\u2380 $cb8"] ;#Insertion Symbol from Miscellaneous Technical - 1 wide + pad tcl::dict::set hack ST [list \x9c "${ob8}\u2383 $cb8"] ;#Emphasis Symbol from Miscellaneous Technical - 1 wide + pad (graphically related to \u2380) tcl::dict::set hack CSI [list \x9b "${ob8}\u2386 $cb8"] ;#Enter Symbol from Miscellaneous Technical - 1 wide + pad - tcl::dict::set hack OSC [list \x9d "${ob8}\u2b55$cb8"] ;#bright red ring from Miscellaneous Symbols and Arrows - 2 wide (OSC could be used for clipboard or other potentially security sensitive functions) + tcl::dict::set hack OSC [list \x9d "${ob8}\u2b55$cb8"] ;#bright red ring from Miscellaneous Symbols and Arrows - 2 wide (OSC could be used for clipboard or other potentially security sensitive functions) tcl::dict::set hack PM [list \x9e "${ob8}PM$cb8"] tcl::dict::set hack APC [list \x9f "${ob8}\U1f534$cb8"] ;#bright red ball from Miscellaneoust Symbols and Pictographs - 2 wide (APC also noted as a potential security risk) - set debug_visuals [tcl::dict::merge $visuals_c0 $visuals_c1 $hack] + set debug_visuals [tcl::dict::merge $visuals_c0 $visuals_c1 $hack $visuals_tags] - #for repeated interaction with the same ANSI string - a mechanism to store state is more efficient + #for repeated interaction with the same ANSI string - a mechanism to store state is more efficient proc NEW {string} { punk::ansi::class::class_ansistring new $string } @@ -5836,12 +6871,13 @@ tcl::namespace::eval punk::ansi::ansistring { -cr 1\ -lf 0\ -vt 0\ + -ff 1\ -ht 1\ -bs 1\ -sp 1\ ] set argopts [lrange $args 0 end-1] - if {[llength $argopts] % 2 != 0} { + if {[llength $argopts] % 2} { error "ansistring VIEW options must be option-value pairs, received '$argopts'. Known opts [tcl::dict::keys $defaults]" } set opts [tcl::dict::merge $defaults $argopts] @@ -5850,16 +6886,22 @@ tcl::namespace::eval punk::ansi::ansistring { set opt_cr [tcl::dict::get $opts -cr] set opt_lf [tcl::dict::get $opts -lf] set opt_vt [tcl::dict::get $opts -vt] + set opt_ff [tcl::dict::get $opts -ff] set opt_ht [tcl::dict::get $opts -ht] set opt_bs [tcl::dict::get $opts -bs] set opt_sp [tcl::dict::get $opts -sp] # -- --- --- --- --- + # -lf 2, -vt 2 and -ff 2 are useful for CRM mode (Show Control Character Mode) in the terminal - where a newline is expected to display after the character. - set visuals_opt $debug_visuals + set visuals_opt $debug_visuals + set visuals_opt [dict remove $visuals_opt CR ESC LF VT FF HT BS SP] + if {$opt_esc} { tcl::dict::set visuals_opt ESC [list \x1b \u241b] + } else { + tcl::dict::unset visuals_opt ESC } if {$opt_cr} { tcl::dict::set visuals_opt CR [list \x0d \u240d] @@ -5870,9 +6912,20 @@ tcl::namespace::eval punk::ansi::ansistring { if {$opt_lf == 2} { tcl::dict::set visuals_opt LF [list \x0a \u240a\n] } - if {$opt_vt} { + if {$opt_vt == 1} { tcl::dict::set visuals_opt VT [list \x0b \u240b] } + if {$opt_vt == 2} { + tcl::dict::set visuals_opt VT [list \x0b \u240b\n] + } + switch -exact -- $opt_ff { + 1 { + tcl::dict::set visuals_opt FF [list \x0c \u240c] + } + 2 { + tcl::dict::set visuals_opt FF [list \x0c \u240c\n] + } + } if {$opt_ht} { tcl::dict::set visuals_opt HT [list \x09 \u2409] } @@ -5897,7 +6950,7 @@ tcl::namespace::eval punk::ansi::ansistring { } #The implementation of viewcodes,viewstyle is more efficiently done in an object for the case where repeated calls of various methods can re-use the internal splits. - #for oneshots here - there is only minor overhead to use and destroy the object here. + #for oneshots here - there is only minor overhead to use and destroy the object here. proc VIEWCODES {args} { set string [lindex $args end] if {$string eq ""} { @@ -5909,7 +6962,7 @@ tcl::namespace::eval punk::ansi::ansistring { $ansistr destroy return $result } - #an attempt to show the codes and colour/style of the *input* + #an attempt to show the codes and colour/style of the *input* #ie we aren't looking at the row/column positioning - but we do want to keep track of cursor attribute saves and restores proc VIEWSTYLE {args} { set string [lindex $args end] @@ -5941,16 +6994,16 @@ tcl::namespace::eval punk::ansi::ansistring { #stripping diacritics only makes sense if we are counting them as combiners and also treating unicode grapheme combinations as single entities. #as Our ansistring INDEX function returns the character with diacritics, and will ultimately return grapheme clusters as a single element - we strip theme here as not counted. #todo - combiners/diacritics? just map them away here? - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set string [regsub -all $re_diacritics $string ""] - #we want length to return number of glyphs.. not screen width. Has to be consistent with index function + #we want length to return number of glyphs.. not screen width. Has to be consistent with index function tcl::string::length [ansistrip $string] } #included as a test/verification - slightly slower. #grapheme split version may end up being used once it supports unicode grapheme clusters proc count2 {string} { - #we want count to return number of glyphs.. not screen width. Has to be consistent with index function + #we want count to return number of glyphs.. not screen width. Has to be consistent with index function return [llength [punk::char::grapheme_split [ansistrip $string]]] } @@ -6025,7 +7078,7 @@ tcl::namespace::eval punk::ansi::ansistring { } #Note that trim/trimleft/trimright will trim spaces at the extremities that are styled with background colour, underline etc - #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. + #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. proc trimleft {string args} { set intext 0 set out "" @@ -6051,19 +7104,19 @@ tcl::namespace::eval punk::ansi::ansistring { } proc trim {string} { #make sure we do our ansi-scanning split only once - so use list-based trim operations - #order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length + #order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length #we save a single function call by calling both here rather than _splits_trim join [_splits_trimright [_splits_trimleft [split_codes $string]]] "" } - #Capitalised because it's the clustered grapheme/controlchar index - not the tcl string index + #Capitalised because it's the clustered grapheme/controlchar index - not the tcl string index proc INDEX {string index} { #*** !doctools #[call [fun index] [arg string] [arg index]] #[para]Takes a string that possibly contains ansi codes such as colour,underline etc (SGR codes) #[para]Returns the character (with applied ansi effect) at position index #[para]The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output. - #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) + #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) #[para]It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them. #[para]If the caller wants just the character - they should use a normal string index after calling ansistrap, or call ansistrip afterwards. #[para]As any operation using end-+ will need to strip ansi to precalculate the length anyway; the caller should probably just use ansistrip and standard string index if the ansi coded output isn't required and they are using and end-based index. @@ -6142,8 +7195,8 @@ tcl::namespace::eval punk::ansi::ansistring { } #any pt could be empty if using split_codes_single (or just first and last pt if split_codes) - set low -1 - set high -1 + set low -1 + set high -1 set pt_index -2 set pt_found -1 set char "" @@ -6157,8 +7210,8 @@ tcl::namespace::eval punk::ansi::ansistring { if {$pt ne ""} { set graphemes [punk::char::grapheme_split $pt] - set low [expr {$high + 1}] ;#last high - #incr high [tcl::string::length $pt] + set low [expr {$high + 1}] ;#last high + #incr high [tcl::string::length $pt] incr high [llength $graphemes] } @@ -6168,14 +7221,14 @@ tcl::namespace::eval punk::ansi::ansistring { set char [lindex $graphemes $index-$low] break } - + if {[punk::ansi::codetype::is_sgr_reset $code]} { - #we can throw away previous codestack + #we can throw away previous codestack set codestack [list] } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { set codestack [list $code] } else { - #may have partial resets + #may have partial resets #sgr_merge_list will handle at end #we don't apply non SGR codes to our output. This is probably what is wanted - but should be reviewed. #Review - consider if any other types of code make sense to retain in the output in this context. @@ -6192,8 +7245,8 @@ tcl::namespace::eval punk::ansi::ansistring { } } - #helper to convert indices (possibly of form x+y end-x etc) to numeric values within the payload range i.e without ansi - #return empty string for each index that is out of range + #helper to convert indices (possibly of form x+y end-x etc) to numeric values within the payload range i.e without ansi + #return empty string for each index that is out of range #review - this is possibly too slow to be very useful as is. # consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string #see also punk::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them. @@ -6274,11 +7327,11 @@ tcl::namespace::eval punk::ansi::ansistring { #we now have numeric or empty string indices - but haven't fully checked they are within the underlying payload length if {[join $testindices ""] eq ""} { - #don't calc ansistring length if no indices to check + #don't calc ansistring length if no indices to check return $testindices } if {$payload_len == -1} { - set payload_len [punk::ansi::ansistring::length $string] + set payload_len [punk::ansi::ansistring::length $string] } set indices [list] foreach ti $testindices { @@ -6304,7 +7357,7 @@ tcl::namespace::eval punk::ansi::ansistring { #single-width grapheme will return pair of integers of equal value #doulbe-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 + #There is an index per grapheme - whether it is 1 or 2 columns wide set index [lindex [INDEXABSOLUTE $string $idx] 0] if {$index eq ""} { return "" @@ -6325,7 +7378,7 @@ tcl::namespace::eval punk::ansi::ansistring { foreach ptline $ptlines { set graphemes [punk::char::grapheme_split $ptline] if {$ptlineindex > 0} { - #todo - account for previous \n as a grapheme .. what column? It should theoretically be in the rightmost column + #todo - account for previous \n as a grapheme .. what column? It should theoretically be in the rightmost column #zero width set low [expr {$high + 1}] set lowc [expr {$highc + 1}] @@ -6341,7 +7394,7 @@ tcl::namespace::eval punk::ansi::ansistring { set lowc 0 set highc 0 } - set low [expr {$high + 1}] ;#last high + set low [expr {$high + 1}] ;#last high set lowc [expr {$highc + 1}] set high [expr {$low + [llength $graphemes] -1}] set highc [expr {$lowc + [punk::char::ansifreestring_width $ptline] -1}] @@ -6383,7 +7436,7 @@ tcl::namespace::eval punk::ansi::ansistring { if {$pt ne ""} { if {[tcl::string::last \n $pt] < 0} { set graphemes [punk::char::grapheme_split $pt] - set lowindex [expr {$highindex + 1}] ;#last high + set lowindex [expr {$highindex + 1}] ;#last high set lowc [expr {$highc + 1}] set highindex [expr {$lowindex + [llength $graphemes] -1}] set highc [expr {$lowc + [punk::char::ansifreestring_width $pt] -1}] @@ -6412,14 +7465,246 @@ tcl::namespace::eval punk::ansi::ansistring { } } - #inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi - #todo - document - interp alias {} ansistring {} ::punk::ansi::ansistring #*** !doctools #[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}] } + +tcl::namespace::eval punk::ansi::control { + proc APC {args} { + return \x1b_[join $args {;}]\x1b\\ + } + proc APC8 {args} { + return \x9f[join $args {;}]\x9c + } + proc CSI {args} { + set finalarg [lindex $args end] + set finalbyte [string index $finalarg end] + if {![regexp {[\x40-\x73]} $finalbyte]} { + error "::punk::ansi::control::CSI final byte must be one in the set @A-Z\[\\\]^_`a-z\{|\}~" + } + if {$finalarg eq $finalbyte} { + return \x1b\[[join [lrange $args 0 end-1] {;}]$finalbyte + } else { + return \x1b\[[join $args {;}] + } + } + proc CSI8 {args} { + set finalarg [lindex $args end] + set finalbyte [string index $finalarg end] + if {![regexp {[\x40-\x73]} $finalbyte]} { + error "::punk::ansi::control::CSI final byte must be one in the set @A-Z\[\\\]^_`a-z\{|\}~" + } + if {$finalarg eq $finalbyte} { + return \x9b[join [lrange $args 0 end-1] {;}]$finalbyte + } else { + return \x9b[join $args {;}] + } + } + proc DCS {args} { + return \x1bP[join $args {;}]\x1b\\ + } + proc DCS8 {args} { + return \x90[join $args {;}]\x9c + } + proc OSC {args} { + return \x1b\][join $args {;}]\x1b\\ + } + proc OSC8 {args} { + return \x9d[join $args {;}]\x9c + } +} + +namespace eval punk::ansi::colour { + package require punk::assertion + if {[catch {namespace import ::punk::assertion::assert} errM]} { + puts stderr "punk error importing punk::assertion::assert\n$errM" + puts stderr "punk::a* commands:[info commands ::punk::a*]" + } + punk::assertion::active on + + #see also colors package + #https://sourceforge.net/p/irrational-numbers/code/HEAD/tree/pkgs/Colors/trunk/colors.tcl#l159 + + + # classic formula for luminance (0.0 .. 100.0) + proc luminance {R G B} { + return [expr {(0.3*$R + 0.59*$G + 0.11*$B)/255.0}] + } + #New colour's luminance is dark if orig-colour is bright, and viceversa + #(note not all colours are invertable to return original) + proc contrasting {R G B} { + set lum [luminance $R $G $B] + if {$lum < 0.597} { + set lum 0.9 + } else { + set lum 0.2 + } + lassign [RGB2hsl $R $G $B] h s l + return [hsl2RGB $h $s $lum] + } + proc contrast_pair {R G B} { + set contra [contrasting $R $G $B] + set back [contrasting {*}$contra] + return [list $back $contra] ;#back may or may not equal original R G B + } + + + proc hsl2RGB { H S L } { + if { $L < 0.5 } { + set Q [expr {$L*(1.0+$S)}] + } else { + set Q [expr {$L+$S-($L*$S)}] + } + set P [expr {2.0*$L-$Q}] + set Hk [expr {$H/360.0}] + set T(R) [expr {$Hk+1.0/3.0}] + set T(G) $Hk + set T(B) [expr {$Hk-1.0/3.0}] + + # normalize + foreach c {R G B} { + if {$T($c) < 0.0} { set T($c) [expr {$T($c)+1.0}] } + if {$T($c) > 1.0} { set T($c) [expr {$T($c)-1.0}] } + } + + foreach c {R G B} { + if {$T($c) < (1.0/6.0)} { + set T($c) [expr {$P+($Q-$P)*6.0*$T($c)}] + } elseif {$T($c) < 0.5} { + set T($c) $Q + } elseif {$T($c) < (2.0/3.0)} { + set T($c) [expr {$P+($Q-$P)*(2.0/3.0-$T($c))*6.0}] + } else { + set T($c) $P + } + set T($c) [expr {round($T($c)*255)}] + } + + return [list $T(R) $T(G) $T(B)] + } + proc RGB2hsl { R G B } { + set r [expr {$R/255.0}] + set g [expr {$G/255.0}] + set b [expr {$B/255.0}] + + set max $r + set min $r + if { $g > $max } { set max $g } + if { $g < $min } { set min $g } + if { $b > $max } { set max $b } + if { $b < $min } { set min $b } + + if { $max == $min } { + set H 0.0 + } elseif { $b == $max } { + set H [expr {60* ($r-$g)/($max-$min)+240}] + } elseif { $g == $max } { + set H [expr {60* ($b-$r)/($max-$min)+120}] + } else { + # $r == $max + if { $g >= $b } { + set H [expr {60* ($g-$b)/($max-$min)}] + } else { + set H [expr {60* ($g-$b)/($max-$min)+360}] + } + } + + set L [expr {($max+$min)/2}] + + if { $L == 0.0 || $max == $min } { + set S 0.0 + } elseif { $L <= 0.5 } { + set S [expr {($max-$min)/($max+$min)}] + } else { + set S [expr {($max-$min)/(2.0-($max+$min))}] + } + + return [list $H $S $L] + } + + + #red green blue to hsl (hue saturation luminance) + #https://www.rapidtables.com/convert/color/rgb-to-hsl.html + proc jexer_rgb_to_hsl {red green blue} { + #algorithm port from Jexer LegacySixelEncode.java - with thanks to Autumn Lamonte (MIT lic) + assert {$red >=0 && $red <= 255} + assert {$green >=0 && $green <= 255} + assert {$blue >=0 && $blue <= 255} + set R [expr {$red / 255.0}] + set G [expr {$green / 255.0}] + set B [expr {$blue / 255.0}] + set Rmax 0 + set Gmax 0 + set Bmax 0 + set min [expr {$R < $G ? $R : $G}] + set min [expr {$min < $B ? $min : $B}] + set max 0 + if {($R >= $G) && ($R >= $B)} { + set max $R + set Rmax 1 + } elseif {($G >= $R) && ($G >= $B)} { + set max $G + set Gmax 1 + } elseif {($B >= $G) && ($B >= $R)} { + set max $B + set Bmax 1 + } + set L [expr {($min + $max) / 2.0}] + set H 0.0 + set S 0.0 + #REVIEW - java allows floating point division by 0.0 - producing positive infinity, negative infinity or NaN + #This makes the original java algorithm a little more obscure + if {$min != $max} { + #no divide by zero issues due to min != max + if {$L < 0.5} { + set S [expr {($max - $min) / ($max + $min)}] + } else { + set S [expr {($max - $min) / (2.0 - $max - $min)}] + } + } + if {$Rmax} { + #puts "G'$G' B'$B' max'$max' min'$min'" + assert {$Gmax == 0} + assert {$Bmax == 0} + if {($max - $min) == 0} { + set H 0.0 ;#review + } else { + set H [expr {($G - $B) / ($max - $min)}] + } + } elseif {$Gmax} { + assert {$Rmax == 0} + assert {$Bmax == 0} + if {($max - $min) == 0} { + set H 2.0 + } else { + set H [expr {2.0 + ($B - $R) / ($max - $min)}] + } + } elseif {$Bmax} { + assert {$Rmax == 0} + assert {$Gmax == 0} + if {($max - $min) == 0} { + set H 4.0 + } else { + set H [expr {4.0 + ($R - $G) / ($max - $min)}] + } + } + if {$H < 0.0} { + set H [expr {$H + 6.0}] + } + + #Tcl mathfunc round vs int (which rounds down) + set hue [expr {round($H * 60)}] + set sat [expr {round($S * 100)}] + set lum [expr {round($L * 100)}] + assert {$hue >= 0 && $hue <= 360} + assert {$sat >= 0 && $sat <= 100} + assert {$lum >= 0 && $lum <= 100} + + return [list $hue $sat $lum] + } +} tcl::namespace::eval punk::ansi::internal { proc splitn {str {len 1}} { #from textutil::split::splitn @@ -6473,9 +7758,9 @@ tcl::namespace::eval punk::ansi::internal { } proc printing_length_addchar {i c} { - upvar outchars outc + upvar outchars outc upvar outsizes outs - set nxt [llength $outc] + set nxt [llength $outc] if {$i < $nxt} { lset outc $i $c } else { @@ -6496,7 +7781,7 @@ tcl::namespace::eval punk::ansi::internal { if {$2digithexchars eq ""} { return "" } - if {[tcl::string::length $2digithexchars] % 2 != 0} { + if {[tcl::string::length $2digithexchars] % 2} { error "hex2str requires an even number of hex digits (2 per character)" } set 2str "" @@ -6507,11 +7792,20 @@ tcl::namespace::eval punk::ansi::internal { } } +#inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi +#todo - document +interp alias {} ansistring {} ::punk::ansi::ansistring + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::class ::punk::ansi::ta +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::ansi [tcl::namespace::eval punk::ansi { variable version - set version 0.1.1 + set version 0.1.1 }] return 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 index 5e270ac8..91f29aa5 100644 --- 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 @@ -1,6 +1,6 @@ # -*- 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: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# 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. @@ -21,11 +21,11 @@ #[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 --}] +#[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 +#[para]Utilities for parsing proc args # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -50,55 +50,55 @@ #[example { # proc dofilestuff {args} { # lassign [dict values [punk::args::get_dict { -# *proc -help "do some stuff with files e.g dofilestuff " -# *opts -type string +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string # #comment lines ok -# -directory -default "" -# -translation -default binary +# -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]] opts values +# @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" +# 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 *proc *opts *values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[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]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 +# -directory -default "" +# -translation -default binary # -nocomplain -type none -# *values -min 2 -max 2 +# @values -min 2 -max 2 # fileA -type existingfile 1 # fileB -type existingfile 1 -# } $args]] opts values +# } $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]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]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} +# category -choices {cat1 cat2 cat3} # another_leading_arg -type boolean # } [list $category $another_leading_arg] -#}] +#}] #*** !doctools #[subsection Notes] @@ -111,8 +111,8 @@ # proc test_switch {args} { # set opts [dict create\\ # -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ +# -frametype "heavy"\\ +# -show_edge 1\\ # -show_seps 0\\ # -x a\\ # -y b\\ @@ -173,12 +173,12 @@ #[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] (* 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]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. @@ -188,7 +188,7 @@ #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 +#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 @@ -201,6 +201,8 @@ #[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-}] @@ -216,110 +218,509 @@ package require Tcl 8.6- #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::class { +tcl::namespace::eval punk::args::register { #*** !doctools - #[subsection {Namespace punk::args::class}] - #[para] class definitions - if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] + #[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] - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[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. - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } + # -- --- --- --- --- --- --- --- + #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] + } + # -- --- --- --- --- --- --- --- - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } + 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 class enumeration ---}] - } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] } -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::args { - tcl::namespace::export {[a-z]*} - variable argspec_cache - variable argspecs - variable id_counter - set argspec_cache [tcl::dict::create] - set argspecs [tcl::dict::create] - set id_counter 0 + + + 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 + #[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 ? (applies to opts only not values) - #e.g -background -synonym -bg -default White - proc Get_argspecs {optionspecs args} { - variable argspec_cache - variable argspecs - variable initial_optspec_defaults - variable initial_valspec_defaults - #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. - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - set cache_key $optionspecs - if {[tcl::dict::exists $argspec_cache $cache_key]} { - return [tcl::dict::get $argspec_cache $cache_key] - } - set optionspecs [tcl::string::map [list \r\n \n] $optionspecs] + + #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_without_ansi 0\ + -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_without_ansi 0\ + -validate_ansistripped 0\ -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ ] - #checks with no default - #-minlen -maxlen -range + #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] + } + } + - #default -allow_ansi to 1 and -validate_without_ansi to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_without_ansi 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + #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 arg_info [tcl::dict::create] - set arg_checks [tcl::dict::create] + set opt_defaults [tcl::dict::create] - set opt_names [list] ;#defined opts + set val_defaults [tcl::dict::create] set opt_solos [list] - #first process dashed and non-dashed argspecs without regard to whether non-dashed are at the beginning or end - set val_names [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 "" @@ -333,20 +734,41 @@ tcl::namespace::eval punk::args { } #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) - if {![tcl::info::complete [punk::ansi::ansistrip $recordsofar]]} { + #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} { - if {[tcl::string::length $lastindent]} { - #trim only the whitespace corresponding to last indent - 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 \n - } else { - append linebuild $rawline \n - } + #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 } @@ -354,484 +776,2634 @@ tcl::namespace::eval punk::args { set in_record 1 regexp {(\s*).*} $rawline _all lastindent #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " + #puts "indent from rawline:$rawline " append linebuild $rawline \n } } else { set in_record 0 - if {[tcl::string::length $lastindent]} { - #trim only the whitespace corresponding to last indent - 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 - } else { - append linebuild $rawline - } + #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 + lappend records $linebuild set linebuild "" } } - set proc_info {} + 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 spec_id "" - foreach ln $records { - set trimln [tcl::string::trim $ln] - switch -- [tcl::string::index $trimln 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} } - set linespecs [lassign $trimln argname] - if {$argname ne "*id" && [llength $linespecs] %2 != 0} { - error "punk::args::get_dict - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs'" + 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 $argname 0] - set secondchar [tcl::string::index $argname 1] - if {$firstchar eq "*" && $secondchar ne "*"} { - set starspecs $linespecs - switch -- [tcl::string::range $argname 1 end] { + # ---------------------------------------------------------- + + 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 { - #id line must have single entry - a unique id assigned by the user - an id will be allocated if no id line present or the value is "auto" - if {[llength $starspecs] != 1} { - error "punk::args::Get_argspecs - *id line must have a single entry following *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" + } } - if {$spec_id ne ""} { - #disallow duplicate *id line - error "punk::args::Get_argspecs - *id already set. Existing value $spec_id" - } - set spec_id $starspecs + set id_info $at_specs } - proc { - #allow arbitrary - review - set proc_info $starspecs + 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] + } } - opts { - foreach {k v} $starspecs { - switch -- $k { - -any - - -anyopts { - set opt_any $v + 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] } - -minlen - -maxlen - -range - -choices - -choicelabels { - #review - only apply to certain types? - tcl::dict::set optspec_defaults $k $v + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] } - -nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels { - if {$v} { - tcl::dict::unset optspec_defaults $k + 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??? } - -type { - switch -- $v { - int - integer { - set v int + } + } + } + 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- + } } - char - character { - set v char + 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" } - bool - boolean { - set v bool + 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 - dictionary { - set v dict + 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" } - none - any - ansistring { - + 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 } - list { + } + -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- + } } - 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" } - tcl::dict::set optspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_without_ansi - - -strip_ansi - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set optspec_defaults $k $v - } - default { - set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels\ - -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ - } - error "punk::args::Get_argspecs - unrecognised key '$k' in *opts line. Known keys: $known" } } - } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + } values { - foreach {k v} $starspecs { - switch -- $k { - -min - - -minvalues { - set val_min $v - } - -max - - -maxvalues { - set val_max $v - } - -minlen - -maxlen - -range - -choices - -choicelabels { - #review - only apply to certain types? - tcl::dict::set valspec_defaults $k $v - } - -nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels { - if {$v} { - tcl::dict::unset valspec_defaults $k + 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 { } - } - -type { - switch -- $v { - int - integer { - set v int + -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" } - char - character { - set v char + 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" } - bool - boolean { - set v bool + 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" } - dict - dictionary { - set v dict + 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 } - list { + } + -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- + } } - 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" } - tcl::dict::set valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_without_ansi - - -strip_ansi - - -multiple { - tcl::dict::set valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minlen -maxlen -range -choices -choicelabels\ - -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ - } - error "punk::args::Get_argspecs - unrecognised key '$k' in *values line. Known keys: $known" } } + 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::Get_argspecs - unrecognised * line in '$ln'. Expected *proc *opts or *values - use **name if paramname needs to be *name" + 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 argspecs $linespecs - tcl::dict::set argspecs -ARGTYPE option - lappend opt_names $argname + 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 { - if {$firstchar eq "*"} { - #allow basic ** escaping for literal argname that begins with * + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ set argname [tcl::string::range $argname 1 end] } - set argspecs $linespecs - tcl::dict::set argspecs -ARGTYPE value - lappend val_names $argname - set is_opt 0 - } - #assert - we only get here if it is a value or flag specification line. - #assert argspecs has been set to the value of linespecs - if {$is_opt} { - set spec_merged $optspec_defaults - } else { - set spec_merged $valspec_defaults - } - foreach {spec specval} $argspecs { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -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::get_dict - invalid -type 'none' for positional argument positional argument '$argname'" - } - } - any - ansistring { - tcl::dict::set spec_merged -type any - } - 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] - } + + 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 } - -default - -solo - -range - -choices - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { - #review -solo 1 vs -type none ? - tcl::dict::set spec_merged $spec $specval - } - default { - set known_argspecs [list -default -type -range -choices -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help] - error "punk::args::get_dict - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" - } - } - } - set argspecs $spec_merged - if {$is_opt} { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen - } else { - set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen - } - tcl::dict::set arg_info $argname $argspecs - tcl::dict::set arg_checks $argname $argchecks - #review existence of -default overriding -optional - if {![tcl::dict::get $argspecs -optional] && ![tcl::dict::exists $argspecs -default]} { - if {$is_opt} { - lappend opt_required $argname - } else { - lappend val_required $argname } + + set is_opt 0 } - if {[tcl::dict::exists $argspecs -default]} { + + + #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} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $argspecs -default] + set spec_merged [dict get $F $fid optspec_defaults] } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $argspecs -default] + 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] + } } - } - } - #confirm any valnames before last don't have -multiple key - foreach valname [lrange $val_names 0 end-1] { - if {[tcl::dict::get $arg_info $valname -multiple]} { - error "bad key -multiple on argument spec for '$valname'. Only the last value argument specification can be marked -multiple" - } + # -> 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 } - if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { - variable id_counter - set spec_id "autoid_[incr id_counter]" - } - - - set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen - set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen - - set result [tcl::dict::create\ - id $spec_id\ - arg_info $arg_info\ - arg_checks $arg_checks\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - opt_names $opt_names\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults $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 $valspec_defaults\ - val_checks_defaults $val_checks_defaults\ - proc_info $proc_info\ + + + + + #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 argspec_cache $cache_key $result - tcl::dict::set argspecs $spec_id $optionspecs + + 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 $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} { - variable argspecs - if {[tcl::dict::exists $argspecs $id]} { - return [tcl::dict::get $argspecs $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 } - return + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result } - proc get_spec_ids {{match *}} { - variable argspecs - return [tcl::dict::keys $argspecs $match] + + #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 } - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - set cmdinfo [tcl::dict::get [tcl::info::frame -3] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - set cmdinfo "punk::args::get_dict called from namespace" + 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" } - return $cmdinfo + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist } - proc arg_error {msg spec_dict {badarg ""}} { - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minlen -maxlen) - set errmsg $msg - if {![catch {package require textblock}]} { - if {[catch { - append errmsg \n - set procname [punk::lib::dict_getdef $spec_dict proc_info -name ""] - set prochelp [punk::lib::dict_getdef $spec_dict proc_info -help ""] + #consider - #set t [textblock::class::table new [a+ web-yellow]Usage[a]] - set t [textblock::class::table new [a+ brightyellow]Usage[a]] + #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?... - set blank_header_col [list ""] - if {$procname ne ""} { - lappend blank_header_col "" - #set procname_display [a+ web-white]$procname[a] - set procname_display [a+ brightwhite]$procname[a] - } else { - set procname_display "" + #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 { } - if {$prochelp ne ""} { - lappend blank_header_col "" - #set prochelp_display [a+ web-white]$prochelp[a] - set prochelp_display [a+ brightwhite]$prochelp[a] - } else { - set prochelp_display "" - } - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - if {"$procname$prochelp" eq ""} { - $t configure_header 0 -values {Arg Type Default Multiple Help} - } elseif {$procname eq ""} { - $t configure_header 0 -colspans {1 4 0 0 0} -values [list Description: $prochelp_display] - $t configure_header 1 -values {Arg Type Default Multiple Help} - } elseif {$prochelp eq ""} { - $t configure_header 0 -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display] - $t configure_header 1 -values {Arg Type Default Multiple Help} - } else { - $t configure_header 0 -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display] - $t configure_header 1 -colspans {1 4 0 0 0} -values [list Description: $prochelp_display] - $t configure_header 2 -values {Arg Type Default Multiple Help} - } - - #set c_default [a+ web-white Web-limegreen] - set c_default [a+ brightwhite Brightgreen] - #set c_badarg [a+ web-crimson] - set c_badarg [a+ brightred] - #set greencheck [a+ web-limegreen]\u2713[a] - set greencheck [a+ brightgreen]\u2713[a] - - foreach arg [dict get $spec_dict opt_names] { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - #set default $c_default[dict get $arginfo -default] - set default [dict get $arginfo -default] - } else { - set default "" - } - set help [punk::lib::dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - append help "Choices: [dict get $arginfo -choices]" - } - if {[punk::lib::dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } - $t add_row [list $arg [dict get $arginfo -type] $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg - } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" } - foreach arg [dict get $spec_dict val_names] { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - set default [dict get $arginfo -default] - } else { - set default "" - } - set help [punk::lib::dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - append help "Choices: [dict get $arginfo -choices]" - } - if {[punk::lib::dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" + } + } + 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'" } - $t add_row [list $arg [dict get $arginfo -type] $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg + 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'" } - - - #$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ web-white] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] - $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] - $t configure -maxwidth 80 - append errmsg [$t print] - $t destroy - } 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" - } + } + 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 { - #todo - something boring + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" } - #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 ;) - return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg + #TODO } - #todo - a version of get_dict that supports punk::lib::tstr templating + #todo? - a version of get_dict that directly supports punk::lib::tstr templating #rename get_dict - #provide ability to look up and reuse definitions from ids etc # #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 {optionspecs args} { + 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] [opt {option value...}]] + #[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: @@ -841,295 +3413,442 @@ tcl::namespace::eval punk::args { #[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]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 *proc *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. + #[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 + #consider line-processing example below for which we need info complete to determine record boundaries #punk::args::get_dict { - # *opts + # @opts # -opt1 -default {} # -opt2 -default { # etc - # } - # *values -multiple 1 + # } + # @values -multiple 1 #} $args - if {[llength $args] == 0} { - set rawargs [list] - } elseif {[llength $args] ==1} { - set rawargs [lindex $args 0] ;#default tcl style - } else { - #todo - can we support tk style vals before flags? - #the aim is to allow a single call to validate standard leading proc positional args along with the $args val which may have flags in tk or tcl order - #by allowing all to be in a single call - we could use a -help (or similar erroring call) to trigger the spec-parsing from a wrapper function. - #this would be important in the case where the function to be wrapped has never been called - but the wrapper needs info about the downstream options - #we would like to avoid the ugliness of trying to parse a proc body to scrape the specification. - #we may still need to do a basic scan of the proc body to determine if it at least contains the string punk::args::get_dict - but that is slightly less odious. - error "unsupported number of arguments for punk::args::get_dict" - set inopt 0 - set k "" - set i 0 - foreach a $args { - switch -- $f { - -opts { - - } - -vals { - - } - -optvals { - #tk style - - } - -valopts { - #tcl style - set rawargs [lindex $args $i+1] - incr i - } - default { - - } - } - incr i - } - } + 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]] - set argspecs [Get_argspecs $optionspecs] + # ----------------------------------------------- + # 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 + #-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 - if {[set eopts [lsearch -exact $rawargs "--"]] >= 0} { - lappend flagsreceived -- - set values [lrange $rawargs $eopts+1 end] - set arglist [lrange $rawargs 0 $eopts-1] - set maxidx [expr {[llength $arglist]-1}] - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $arglist $i] - if {![tcl::string::match -* $a]} { - #we can't treat as first positional arg - as it comes before the eopt indicator -- - arg_error "punk::args::get_dict bad options for [Get_caller]. Expected flag (leading -) at position $i got:$rawargs" $argspecs - } - - if {![catch {tcl::prefix match -message "options for %caller%. Unexpected option" $opt_names $a } fullopt]} { - if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { - #non-solo - set flagval [lindex $arglist $i+1] - if {[dict get $arg_info $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - #review - what if user sets first value that happens to match a default? - if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { - #first occurrence of this flag, whilst stored value matches default - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } + 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 { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - 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 $fullopt + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name } } else { - #type none (solo-flag) - if {[tcl::dict::get $arg_info $fullopt -multiple]} { - if {[tcl::dict::get $opts $fullopt] == 0} { - #review - what if default at time opt was specified is not zero? we will end up with more items in the list than the number of times the flag was specified - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 + #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 } - } else { - tcl::dict::set opts $fullopt 1 } + #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 } - lappend flagsreceived $fullopt ;#dups ok } else { - if {$opt_any} { - set newval [lindex $arglist $i+1] - #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option - tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $opt_checks_defaults - if {[tcl::dict::get $arg_info $a -type] ne "none"} { - if {[tcl::dict::get $arg_info $a -multiple]} { - tcl::dict::lappend opts $a $newval - } else { - tcl::dict::set opts $a $newval - } - lappend flagsreceived $a ;#adhoc flag as supplied - 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 $a - } + #unnamed leader + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { + break } 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 $arg_info $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 - } + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name } } else { - #delay Get_caller so only called in the unhappy path - set errmsg [tcl::string::map [list %caller% [Get_caller]] $fullopt] - arg_error $errmsg $argspecs $fullopt + 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 { - if {[lsearch $rawargs -*] >= 0} { - #no -- end of opts indicator - #to support option values with leading dash e.g -offset -1 , we can't just use the last flagindex to determine start of positional args. - #we break on first non-flag looking argument that isn't in an option's value position and use that index as the division. - #The caller should use -- if the first positional arg is likely or has the potential to start with a dash. - - set maxidx [expr {[llength $rawargs]-1}] - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - #we can automatically rule out arguments containing whitespace from the set of simple flags beginning with a dash - #This helps for example when first value is a dict or list in which the first item happens to begin with a dash - #explicit -- still safer in many cases, but this is a reasonable and fast enough test - if {![tcl::string::match -* $a] || [regexp {\s+} $a]} { - #assume beginning of positional args - incr i -1 - break - } - - if {![catch {tcl::prefix match -message "options for %caller%. Unexpected option" $opt_names $a } fullopt]} { - if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { - #non-solo - set flagval [lindex $rawargs $i+1] - if {[dict get $arg_info $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - #review - what if user sets first value that happens to match a default? - if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { - #first occurrence of this flag, whilst stored value matches default - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } + 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 { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - 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 $fullopt + #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 { - #type none (solo-flag) - if {[tcl::dict::get $arg_info $fullopt -multiple]} { - if {[tcl::dict::get $opts $fullopt] == 0} { - #review - what if default at time opt was specified is not zero? we will end up with more items in the list than the number of times the flag was specified - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - } else { - tcl::dict::set opts $fullopt 1 - } + #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] } - lappend flagsreceived $fullopt ;#dups ok + break } else { - if {$opt_any} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option - tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $opt_checks_defaults - if {[tcl::dict::get $arg_info $a -type] ne "none"} { - if {[tcl::dict::get $arg_info $a -multiple]} { - tcl::dict::lappend opts $a $newval + 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 $a $newval + tcl::dict::set opts $fullopt $flagval } - lappend flagsreceived $a ;#adhoc flag as supplied + #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 adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs $a + 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 { - #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 $arg_info $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 + #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 $a 1 + tcl::dict::lappend opts $fullopt 1 } } else { - tcl::dict::set opts $a 1 + tcl::dict::set opts $fullopt 1 } + incr vals_remaining_possible -1 } + lappend flagsreceived $fullopt ;#dups ok } else { - #delay Get_caller so only called in the unhappy path - set errmsg [tcl::string::map [list %caller% [Get_caller]] $fullopt] - arg_error $errmsg $argspecs $fullopt + #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 } - set arglist [lrange $rawargs 0 $i] - set values [lrange $rawargs $i+1 end] - #puts "$i--->arglist:$arglist" - #puts "$i--->values:$values" + lappend leadernames_received $leadername } else { - set values $rawargs ;#no -flags detected - set arglist [list] + 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 in_multiple "" set valnames_received [list] - set values_dict $val_defaults + set values_dict $val_defaults set num_values [llength $values] - foreach valname $val_names val $values { + foreach valname $VAL_NAMES val $values { if {$validx+1 > $num_values} { break } if {$valname ne ""} { - if {[tcl::dict::get $arg_info $valname -multiple]} { - if {[tcl::dict::exists $val_defaults $valname] && ([tcl::dict::get $val_defaults $valname] eq [tcl::dict::get $values_dict $valname])} { + 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 + set in_multiple $valname } else { - tcl::dict::set values_dict $valname $val + 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 + #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 $validx $val - tcl::dict::set arg_info $validx $valspec_defaults - tcl::dict::set arg_checks $validx $val_checks_defaults - lappend valnames_received $validx + 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} { @@ -1147,31 +3866,34 @@ tcl::namespace::eval punk::args { } } - #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 + #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 will 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 + #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 + #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 - cannot avoid struct::set difference ensemble as it could be c or tcl implementation and we don't have an option to call directly? + #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" + # 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" + # 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 [punk::lib::ldiff $opt_required $flagsreceived]]]} { - arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present in full-length form" $argspecs + 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 [punk::lib::ldiff $val_required $valnames_received]]]} { + 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 } @@ -1181,31 +3903,276 @@ tcl::namespace::eval punk::args { #todo - allow defaults outside of choices/ranges #check types,ranges,choices - set opts_and_values [tcl::dict::merge $opts $values_dict] + 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 "---arg_info:$arg_info" + #puts "---argstate:$argstate" tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $arg_info $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_without_ansi [tcl::dict::get $thisarg -validate_without_ansi] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] + 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 [tcl::dict::exists $thisarg -choices] + 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 {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] + 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 } - if {!$is_allow_ansi} { + + #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 @@ -1215,57 +4182,39 @@ tcl::namespace::eval punk::args { } } } - if {$is_validate_without_ansi} { - #validate_without_ansi 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_without_ansi 0 - set vlist_check $vlist - } - - set is_default 0 - if {$has_default} { - foreach e_check $vlist_check { - if {$e_check eq $defaultval} { - incr is_default - } - } - if {$is_default eq [llength $vlist]} { - set is_default 1 - } else { - #important to set 0 here too e.g if only one element of many matches default - set is_default 0 - } - } #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 - if {$is_default == 0} { + + #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 $argname + 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 { - -minlen { + -minsize { # -1 for disable is as good as zero if {[llength $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -minlen $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs $argname + arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname } } - -maxlen { + -maxsize { if {$checkval ne "-1"} { if {[llength $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -maxlen $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs $argname + arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname } } } @@ -1274,23 +4223,85 @@ tcl::namespace::eval punk::args { } } } - string { + 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 $vlist_check { + foreach e_check $remaining_e_check { #safe jumptable test #dict for {checkopt checkval} $thisarg_checks {} tcl::dict::for {checkopt checkval} $thisarg_checks { switch -- $checkopt { - -minlen { + -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 -minlen $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs $argname + 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 } } - -maxlen { + -maxsize { if {$checkval ne "-1"} { if {[tcl::string::length $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -maxlen $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs $argname + 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 } } } @@ -1299,26 +4310,49 @@ tcl::namespace::eval punk::args { } } } - ansistring { - package require ansi - } 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 - 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 $argname - } - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer between $low and $high. Received: '$e'" $argspecs $argname + 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 $argname + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname } - } + } } } double { @@ -1333,9 +4367,10 @@ tcl::namespace::eval punk::args { 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 $argname + arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname } } } @@ -1346,28 +4381,28 @@ tcl::namespace::eval punk::args { 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 $argname + 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 $argname + 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 { - -minlen { + -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 -minlen $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs $argname + 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 } } - -maxlen { + -maxsize { if {$checkval ne "-1"} { if {[tcl::dict::size $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires dict with -maxlen $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs $argname + 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 } } } @@ -1391,7 +4426,12 @@ tcl::namespace::eval punk::args { xdigit { foreach e $vlist e_check $vlist_check { if {![tcl::string::is $type $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" $argspecs $argname + 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 } } } @@ -1400,21 +4440,22 @@ tcl::namespace::eval punk::args { existingfile - existingdirectory { foreach e $vlist e_check $vlist_check { - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*?<>\;]} $e_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 $argname + 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 $argname + 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 $argname + arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname } } } @@ -1422,61 +4463,79 @@ tcl::namespace::eval punk::args { 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 $argname + arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname } } } } - if {$has_choices} { - #todo -choicelabels - set choices [tcl::dict::get $thisarg -choices] - set nocase [tcl::dict::get $thisarg -nocase] - foreach e $vlist e_check $vlist_check { - if {$nocase} { - set casemsg "(case insensitive)" - set choices_test [tcl::string::tolower $choices] - set v_test [tcl::string::tolower $e_check] - } else { - set casemsg "(case sensitive)" - set v_test $e_check - set choices_test $choices - } - if {$v_test ni $choices_test} { - arg_error "Option $argname for [Get_caller] must be one of the listed values $choices $casemsg. Received: '$e'" $argspecs $argname - } - } - } + } + if {$is_strip_ansi} { - set stripped_list [lmap e $vlist {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + 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]} { - if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { - tcl::dict::set opts $argname $stripped_list - } else { - tcl::dict::set values_dict $argname $stripped_list + 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 { - if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } else { - tcl::dict::set values_dict [lindex $stripped_list 0] + 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. - return [tcl::dict::create opts $opts values $values_dict] + 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" + # #[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 @@ -1489,28 +4548,718 @@ tcl::namespace::eval punk::args { # Secondary API namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::args::lib { + variable PUNKARGS tcl::namespace::export * - tcl::namespace::path [tcl::namespace::parent] + tcl::namespace::path [list [tcl::namespace::parent]] #*** !doctools #[subsection {Namespace punk::args::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 #} + 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 @@ -1518,17 +5267,45 @@ tcl::namespace::eval punk::args::lib { tcl::namespace::eval punk::args::system { #*** !doctools #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API + #[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 +## 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 + set version 0.1.0 }] return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/assertion-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/assertion-0.1.0.tm index bee5a415..80f4b14d 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/assertion-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/assertion-0.1.0.tm @@ -1,6 +1,6 @@ # -*- 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: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. @@ -18,10 +18,10 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin shellspy_module_punk::assertion 0 0.1.0] +#[manpage_begin punkshell_module_punk::assertion 0 0.1.0] #[copyright "2024"] #[titledesc {assertion alternative to control::assert}] [comment {-- Name section and table of contents description --}] -#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] +#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] #[require punk::assertion] #[keywords module assertion assert debug] #[description] @@ -99,9 +99,9 @@ tcl::namespace::eval punk::assertion::class { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin +#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin tcl::namespace::eval punk::assertion::primary { - #tcl::namespace::export {[a-z]*} + #tcl::namespace::export {[a-z]*} tcl::namespace::export assertActive assertInactive proc assertActive {expr args} { @@ -112,7 +112,7 @@ tcl::namespace::eval punk::assertion::primary { if {![tcl::string::is boolean -strict $res]} { return -code error "invalid boolean expression: $expr" } - + if {$res} {return} if {[llength $args]} { @@ -130,9 +130,9 @@ tcl::namespace::eval punk::assertion::primary { } tcl::namespace::eval punk::assertion::secondary { - tcl::namespace::export * + tcl::namespace::export * #we need to actually define these procs here, (not import then re-export) - or namespace origin will report the original source namespace - which isn't what we want. - proc assertActive {expr args} [tcl::info::body ::punk::assertion::primary::assertActive] + proc assertActive {expr args} [tcl::info::body ::punk::assertion::primary::assertActive] proc assertInactive args {} } @@ -151,7 +151,7 @@ tcl::namespace::eval punk::assertion { } do_ns_import #puts --------BBB - rename assertActive assert + rename assertActive assert } @@ -162,20 +162,20 @@ tcl::namespace::eval punk::assertion { #*** !doctools #[subsection {Namespace punk::assertion}] - #[para] Core API functions for punk::assertion + #[para] Core API functions for punk::assertion #[list_begin definitions] #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" #} #like tcllib's control::assert - we are limited to the same callback for all namespaces. @@ -218,7 +218,7 @@ tcl::namespace::eval punk::assertion { if {$on_off} { #Enable it in calling namespace if {"assert" eq $info_command} { - #There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) + #There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] @@ -243,7 +243,7 @@ tcl::namespace::eval punk::assertion { } return 1 } else { - #assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace + #assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] if {[tcl::string::match ::punk::assertion::* $assertorigin]} { @@ -303,8 +303,8 @@ tcl::namespace::eval punk::assertion { return 0 } } else { - #no assert command reachable - #If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path + #no assert command reachable + #If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" return 0 } @@ -327,14 +327,14 @@ tcl::namespace::eval punk::assertion::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::assertion::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 #} @@ -352,7 +352,7 @@ tcl::namespace::eval punk::assertion::lib { tcl::namespace::eval punk::assertion::system { #*** !doctools #[subsection {Namespace punk::assertion::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #Maintenance - snarfed from punk::ns to reduce dependencies - punk::ns::nsprefix is the master version #nsprefix/nstail are string functions - they do not concern themselves with what namespaces are present in the system @@ -375,7 +375,7 @@ tcl::namespace::eval punk::assertion::system { proc nstail {nspath args} { #normalize the common case of :::: set nspath [tcl::string::map [list :::: ::] $nspath] - set mapped [tcl::string::map [list :: \u0FFF] $nspath] + set mapped [tcl::string::map [list :: \u0FFF] $nspath] set parts [split $mapped \u0FFF] set defaults [list -strict 0] @@ -411,11 +411,11 @@ tcl::namespace::eval punk::assertion::system { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::assertion [tcl::namespace::eval punk::assertion { variable pkg punk::assertion 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/punk/cap-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/cap-0.1.0.tm index 68d3252e..2ede3723 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/cap-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/cap-0.1.0.tm @@ -26,7 +26,7 @@ #[para]punk::cap provides management of named capabilities and the provider packages and handler packages that implement a pluggable capability. #[para]see also [uri https://core.tcl-lang.org/tcllib/doc/trunk/embedded/md/tcllib/files/modules/pluginmgr/pluginmgr.md {tcllib pluginmgr}] for an alternative which uses safe interpreters #[subsection Concepts] -#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API +#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API # #[para][term {capability handler}] - a package/namespace which may provide validation and standardised ways of looking up provider data # registered (or not) using register_capabilityname @@ -49,7 +49,7 @@ package require oolib # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::cap { - variable pkgcapsdeclared [tcl::dict::create] + variable pkgcapsdeclared [tcl::dict::create] variable pkgcapsaccepted [tcl::dict::create] variable caps [tcl::dict::create] namespace eval class { @@ -71,8 +71,8 @@ tcl::namespace::eval punk::cap { #*** !doctools #[call class::interface_caphandler.registry [method pkg_register] [arg pkg] [arg capname] [arg capdict] [arg fullcapabilitylist]] #handler may override and return 0 (indicating don't register)e.g if pkg capdict data wasn't valid - #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. - return 1 ;#default to permit + #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. + return 1 ;#default to permit } method pkg_unregister {pkg} { #*** !doctools @@ -106,9 +106,9 @@ tcl::namespace::eval punk::cap { oo::class create ::punk::cap::class::interface_capprovider.registration { #*** !doctools # [enum] CLASS [class interface_cappprovider.registration] - # [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. + # [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. # [para]If your package namespace is mypackages::providerpkg then the object command would be at mypackages::providerpkg::capsystem::capprovider.registration - # [para]Example code for your provider package to evaluate within its namespace: + # [para]Example code for your provider package to evaluate within its namespace: # [example { #namespace eval capsystem { # if {[info commands capprovider.registration] eq ""} { @@ -133,7 +133,7 @@ tcl::namespace::eval punk::cap { #[para] This method must be overridden by your provider using oo::objdefine cappprovider.registration as in the example above. # There must be at least one 2-element list in the result for the provider to be registerable. #[para]The first element of the list is the capabilityname - which can be custom to your provider/handler packages - or a well-known name that other authors may use/implement. - #[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. + #[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. error "interface_capprovider.registration not implemented by provider" } #*** !doctools @@ -142,11 +142,11 @@ tcl::namespace::eval punk::cap { oo::class create ::punk::cap::class::interface_capprovider.provider { #*** !doctools - # [enum] CLASS [class interface_capprovider.provider] - # [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] + # [enum] CLASS [class interface_capprovider.provider] + # [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] # [example { - # namespace eval mypackages::providerpkg { - # punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg + # namespace eval mypackages::providerpkg { + # punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg # } # }] # [list_begin definitions] @@ -229,7 +229,7 @@ tcl::namespace::eval punk::cap { #Not all capability names have to be registered. #A package registering as a provider using register_package can include capabilitynames in it's capabilitylist which have no associated handler. - #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. + #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. #we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later. proc register_capabilityname {capname capnamespace} { #puts stderr "REGISTER_CAPABILITYNAME $capname $capnamespace" @@ -243,10 +243,10 @@ tcl::namespace::eval punk::cap { } } #allow register of existing capname iff there is no current handler - #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package - #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers + #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package + #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers if {[set hdlr [capability_get_handler $capname]] ne ""} { - puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" + puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" return } #assertion: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. @@ -295,14 +295,14 @@ tcl::namespace::eval punk::cap { if {$count == 0} { set pkgposn [lsearch $providers $pkg] if {$pkgposn >= 0} { - set updated_providers [lreplace $providers $posn $posn] + set updated_providers [lreplace $providers $posn $posn] tcl::dict::set caps $capname providers $updated_providers } } } } - + } } proc capability_exists {capname} { @@ -328,7 +328,7 @@ tcl::namespace::eval punk::cap { if {[tcl::dict::exists $caps $capname]} { return [tcl::dict::get $caps $capname handler] } - return "" + return "" } proc call_handler {capname args} { if {[set handler [capability_get_handler $capname]] eq ""} { @@ -461,7 +461,7 @@ tcl::namespace::eval punk::cap { #todo! proc unregister_package {pkg {capname *}} { - variable pkgcapsdeclared + variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] @@ -471,7 +471,7 @@ tcl::namespace::eval punk::cap { set capabilitylist [dict get $pkgcapsdeclared $pkg] foreach c $capabilitylist { set do_unregister 1 - lassign $c capname _capdict + lassign $c capname _capdict set cap_info [dict get $caps $capname] set pkglist [dict get $cap_info providers] set posn [lsearch $pkglist $pkg] @@ -479,9 +479,9 @@ tcl::namespace::eval punk::cap { if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { #review # it seems not useful to allow the callback to block this unregister action - #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter - #vetoing unregister would make this more complex for no particular advantage - #if per dataset deregistration required this should probably be a separate thing + #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter + #vetoing unregister would make this more complex for no particular advantage + #if per dataset deregistration required this should probably be a separate thing $capreg pkg_unregister $pkg $capname } set pkglist [lreplace $pkglist $posn $posn] @@ -510,7 +510,7 @@ tcl::namespace::eval punk::cap { } } proc pkgcaps {} { - variable pkgcapsdeclared + variable pkgcapsdeclared variable pkgcapsaccepted set result [dict create] foreach {pkg capsdeclared} $pkgcapsdeclared { @@ -522,7 +522,7 @@ tcl::namespace::eval punk::cap { dict set result $pkg accepted $accepted } return $result - } + } proc capability {capname} { variable caps @@ -565,14 +565,14 @@ tcl::namespace::eval punk::cap { #[subsection {Namespace punk::cap::advanced}] #[para] punk::cap::advanced API. Functions here are generally not the preferred way to interact with punk::cap. #[para] In some cases they may allow interaction in less safe ways or may allow use of features that are unavailable in the base namespace. - #[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. + #[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. #[list_begin definitions] proc promote_provider {pkg} { #*** !doctools # [call advanced::[fun promote_provider] [arg pkg]] #[para]Move the named provider package to the preferred end of the list (tail). - #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. + #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. #[para] #[para] promote/demote doesn't always make a lot of sense .. should preferably be configurable per capapbility for multicap provider pkgs #[para]The idea is to provide a crude way to preference/depreference packages independently of order the packages were loaded @@ -615,7 +615,7 @@ tcl::namespace::eval punk::cap { #*** !doctools # [call advanced::[fun demote_provider] [arg pkg]] #[para]Move the named provider package to the preferred end of the list (tail). - #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. + #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { @@ -677,11 +677,11 @@ tcl::namespace::eval punk::cap { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap [namespace eval punk::cap { variable version variable pkg punk::cap - set version 0.1.0 + set version 0.1.0 variable README.md [string map [list %pkg% $pkg %ver% $version] { # punk capabilities system ## pkg: %pkg% version: %ver% diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm index 8fdce944..4a19666b 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm @@ -43,10 +43,10 @@ namespace eval punk::cap::handlers::caphandler { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { variable pkg punk::cap::handlers::caphandler variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm index 2926b237..aaa595ae 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -23,7 +23,7 @@ package require punk::repo # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #register using: -# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates +# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates #By convention and for consistency, we don't register here during package loading - but require the calling app to do it. # (even if it tends to be done immediately after package require anyway) @@ -67,11 +67,11 @@ namespace eval punk::cap::handlers::templates { #for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the projectbase rather than rechecking it each time the templates handler api is called - #for template pathtype absolute - we can do the same. - #There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. + #for template pathtype absolute - we can do the same. + #There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. #adhoc and currentproject* paths are relative to cwd - so no projectbase information can be stored at registration time. - #not all template item types will need projectbase information - as the item data may be self-contained within the template structure - + #not all template item types will need projectbase information - as the item data may be self-contained within the template structure - #but project_layout will need it - or at least need to know if there is no project - because project_layout data is never stored in the template folder structure directly. switch -- $pathtype { adhoc { @@ -95,7 +95,7 @@ namespace eval punk::cap::handlers::templates { } else { set tm_exists [file exists $tmfile] } - if {![file exists $tmfile]} { + if {!$tm_exists} { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" flush stderr return 0 @@ -108,8 +108,10 @@ namespace eval punk::cap::handlers::templates { #todo - handle wrapped or unwrapped tarjar files - in which case we have to adjust tmfolder appropriately #set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder - set projectinfo [punk::repo::find_repos $tmfolder] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $tmfolder] ;#slow - REVIEW + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $tmfolder] + #store the projectbase even if it's empty string set extended_capdict $capdict set resolved_path [file join $tmfolder $path] @@ -128,7 +130,7 @@ namespace eval punk::cap::handlers::templates { } set extended_capdict $capdict - dict set extended_capdict vendor $vendor ;#vendor key still required.. controlling vendor? + dict set extended_capdict vendor $vendor ;#vendor key still required.. controlling vendor? } currentproject { if {[file pathtype $path] ne "relative"} { @@ -140,7 +142,7 @@ namespace eval punk::cap::handlers::templates { set extended_capdict $capdict - dict set extended_capdict vendor $vendor + dict set extended_capdict vendor $vendor } shellproject { if {[file pathtype $path] ne "relative"} { @@ -148,9 +150,10 @@ namespace eval punk::cap::handlers::templates { return 0 } set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review - set projectinfo [punk::repo::find_repos $shellbase] - set projectbase [dict get $projectinfo closest] - + #set projectinfo [punk::repo::find_repos $shellbase] + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $shellbase] + set extended_capdict $capdict dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase @@ -166,11 +169,12 @@ namespace eval punk::cap::handlers::templates { return 0 } set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review - set projectinfo [punk::repo::find_repos $shellbase] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $shellbase] + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $shellbase] set extended_capdict $capdict - dict set extended_capdict vendor $vendor + dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase } absolute { @@ -183,12 +187,13 @@ namespace eval punk::cap::handlers::templates { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' which doesn't seem to exist" return 0 } - set projectinfo [punk::repo::find_repos $normpath] - set projectbase [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $normpath] + #set projectbase [dict get $projectinfo closest] + set projectbase [punk::repo::find_project $normpath] #todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder set extended_capdict $capdict - dict set extended_capdict resolved_path $normpath + dict set extended_capdict resolved_path $normpath dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase } @@ -199,7 +204,7 @@ namespace eval punk::cap::handlers::templates { } # -- --- --- --- --- --- --- ---- --- - # update package internal data + # update package internal data # -- --- --- --- --- --- --- ---- --- upvar ::punk::cap::handlers::templates::provider_info_$cname provider_info @@ -208,13 +213,13 @@ namespace eval punk::cap::handlers::templates { } if {![info exists provider_info] || $extended_capdict ni [dict get $provider_info $pkg]} { #this checks for duplicates from the same provider - but not if other providers already added the path - #review - + #review - dict lappend provider_info $pkg $extended_capdict } # -- --- --- --- --- --- --- ---- --- - # instantiation of api at punk::cap::handlers::templates::api_$capname + # instantiation of api at punk::cap::handlers::templates::api_$capname # -- --- --- --- --- --- --- ---- --- set apicmd "::punk::cap::handlers::templates::api_$capname" if {[info commands $apicmd] eq ""} { @@ -227,12 +232,12 @@ namespace eval punk::cap::handlers::templates { upvar ::punk::cap::handlers::templates::handled_caps hcaps foreach capname $hcaps { set cname [string map {. _} $capname] - upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info + upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info dict unset my_provider_info $pkg #destroy api objects? } } - } + } } } @@ -244,6 +249,18 @@ namespace eval punk::cap::handlers::templates { # -- --- --- --- --- --- --- namespace export * namespace eval class { + variable PUNKARGS + #set argd [punk::args::get_dict { + # @id -id "::punk::cap::handlers::templates::class::api folders" + # -startdir -default "" + # @values -max 0 + #} $args] + lappend PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api folders" + -startdir -default "" + @values -max 0 + }] + oo::class create api { #return a dict keyed on folder with source pkg as value constructor {capname} { @@ -253,10 +270,8 @@ namespace eval punk::cap::handlers::templates { set capabilityname $capname } method folders {args} { - set argd [punk::args::get_dict { - -startdir -default "" - *values -max 0 - } $args] + #puts "--folders $args" + set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] set opts [dict get $argd opts] set opt_startdir [dict get $opts -startdir] @@ -269,6 +284,10 @@ namespace eval punk::cap::handlers::templates { set startdir $opt_startdir } } + set searchbase $startdir + #set pathinfo [punk::repo::find_repos $searchbase] ;#relatively slow! REVIEW - pass as arg? cache? + #set pwd_projectroot [dict get $pathinfo closest] + set pwd_projectroot [punk::repo::find_project $searchbase] variable capabilityname @@ -292,7 +311,7 @@ namespace eval punk::cap::handlers::templates { set found_paths_absolute [list] - foreach pkg $providerpkg { + foreach pkg $providerpkg { set found_paths [list] #set acceptedlist [dict get [punk::cap::pkgcap $pkg $capabilityname] accepted] @@ -313,13 +332,13 @@ namespace eval punk::cap::handlers::templates { set module_projectroot [dict get $capdecl_extended projectbase] dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot] } elseif {$pathtype eq "currentproject_multivendor"} { - set searchbase $startdir - set pathinfo [punk::repo::find_repos $searchbase] - set pwd_projectroot [dict get $pathinfo closest] + #set searchbase $startdir + #set pathinfo [punk::repo::find_repos $searchbase] + #set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { set deckbase [file join $pwd_projectroot $path] if {![file exists $deckbase]} { - continue + continue } #add vendor/x folders first - earlier in list is lower priority set vendorbase [file join $deckbase vendor] @@ -348,9 +367,9 @@ namespace eval punk::cap::handlers::templates { } } } elseif {$pathtype eq "currentproject"} { - set searchbase $startdir - set pathinfo [punk::repo::find_repos $searchbase] - set pwd_projectroot [dict get $pathinfo closest] + #set searchbase $startdir + #set pathinfo [punk::repo::find_repos $searchbase] + #set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { #path relative to projectroot already validated by handler as being within a currentproject_multivendor tree set targetfolder [file join $pwd_projectroot $path] @@ -368,7 +387,7 @@ namespace eval punk::cap::handlers::templates { if {$shell_projectroot ne ""} { set deckbase [file join $shell_projectroot $path] if {![file exists $deckbase]} { - continue + continue } #add vendor/x folders first - earlier in list is lower priority set vendorbase [file join $deckbase vendor] @@ -470,25 +489,27 @@ namespace eval punk::cap::handlers::templates { return $folderdict } method get_itemdict_projectlayouts {args} { - set argd [punk::args::get_dict { - *opts -anyopts 1 + set argd [punk::args::get_dict { + @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" + @opts -anyopts 1 #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here -startdir -default "" - *values -maxvalues -1 - } $args] + @values -maxvalues -1 + } $args] set opt_startdir [dict get $argd opts -startdir] if {$opt_startdir eq ""} { set searchbase [pwd] } else { - set searchbase $opt_startdir + set searchbase $opt_startdir } set refdict [my get_itemdict_projectlayoutrefs {*}$args] set layoutdict [dict create] - set projectinfo [punk::repo::find_repos $searchbase] - set projectroot [dict get $projectinfo closest] + #set projectinfo [punk::repo::find_repos $searchbase] + #set projectroot [dict get $projectinfo closest] + set projectroot [punk::repo::find_project $searchbase] dict for {layoutname refinfo} $refdict { set templatepathtype [dict get $refinfo sourceinfo pathtype] @@ -500,16 +521,18 @@ namespace eval punk::cap::handlers::templates { # e.g ref may be @vendor+punks+othersample@sample-0.1 or layoutalias-1.1@vendor+punk+othersample@sample-0.1 #there must always be an @ before vendor or custom . There is either a template-name alias or empty string before this first @ #trim off first @ part - set tailats [join [lrange $atparts 1 end] @] + set tailats [join [lrange $atparts 1 end] @] # @ parts after the first are part of the path within the project_layouts structure set subpathlist [split $tailats +] if {[dict exists $refinfo sourceinfo projectbase]} { #some template pathtypes refer to the projectroot from the template - not the cwd - set projectroot [dict get $refinfo sourceinfo projectbase] + set ref_projectroot [dict get $refinfo sourceinfo projectbase] + } else { + set ref_projectroot $projectroot } - if {$projectroot ne ""} { - set layoutroot [file join $projectroot src/project_layouts] + if {$ref_projectroot ne ""} { + set layoutroot [file join $ref_projectroot src/project_layouts] set layoutfolder [file join $layoutroot {*}$subpathlist] if {[file isdirectory $layoutfolder]} { #todo - check if layoutname already in layoutdict append .ref path to list of refs that linked to this layout? @@ -549,7 +572,7 @@ namespace eval punk::cap::handlers::templates { if {$vendor ne "_project"} { set itemname $vendor.$itemname } - return $itemname + return $itemname }}} } set arglist [concat $config $args] @@ -619,7 +642,7 @@ namespace eval punk::cap::handlers::templates { }}}\ -command_get_item_name {apply {{vendor basefolder itempath} { - set relativepath [punk::path::relative $basefolder $itempath] + set relativepath [punk::path::relative $basefolder $itempath] set dirs [file dirname $relativepath] if {$dirs eq "."} { set dirs "" @@ -632,7 +655,7 @@ namespace eval punk::cap::handlers::templates { } if {$vendor ne "_project"} { set tname ${vendor}.$tname - } + } return $tname }}} } @@ -641,19 +664,20 @@ namespace eval punk::cap::handlers::templates { } #shared algorithm for get_itemdict_* methods - #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search + #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #and a file selection mechanism command -command_get_items_from_base #and a name determining command -command_get_item_name method _get_itemdict {args} { - set argd [punk::args::get_dict { - *proc -name _get_itemdict - *opts -anyopts 0 + set argd [punk::args::get_dict { + @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" + @cmd -name _get_itemdict + @opts -anyopts 0 -startdir -default "" -templatefolder_subdir -optional 0 -command_get_items_from_base -optional 0 -command_get_item_name -optional 0 - -not -default "" -multiple 1 - *values -maxvalues -1 + -not -default "" -multiple 1 + @values -maxvalues -1 globsearches -default * -multiple 1 } $args] set opts [dict get $argd opts] @@ -692,12 +716,12 @@ namespace eval punk::cap::handlers::templates { set items_here [dict create] ;#maintain a list keyed on name for sorting within this base only foreach itempath $matches { set itemname [{*}$opt_command_get_item_name $vendor $basefolder $itempath] - dict set items_here $itemname [list item $itempath baseinfo $baseinfo] + dict set items_here $itemname [list item $itempath baseinfo $baseinfo] #lappend items [list item $itempath baseinfo $baseinfo] } set ordered_names [lsort [dict keys $items_here]] - #add to the outer items list - foreach nm $ordered_names { + #add to the outer items list + foreach nm $ordered_names { set iteminfo [dict get $items_here $nm] lappend items [list originalname $nm iteminfo $iteminfo] } @@ -710,8 +734,8 @@ namespace eval punk::cap::handlers::templates { set itempath [dict get $iteminfo item] set baseinfo [dict get $iteminfo baseinfo] if {![dict exists $seen_dict $oname]} { - dict set seen_dict $oname 1 - dict set itemdict $oname [list path $itempath {*}$baseinfo] ; #first seen of oname gets no number + dict set seen_dict $oname 1 + dict set itemdict $oname [list path $itempath {*}$baseinfo] ; #first seen of oname gets no number } else { set n [dict get $seen_dict $oname] incr n @@ -725,7 +749,7 @@ namespace eval punk::cap::handlers::templates { set result [dict create] set keys [lreverse [dict keys $itemdict]] foreach k $keys { - set maybe "" + set maybe "" foreach g $globsearches { if {[string match $g $k]} { set maybe $k @@ -740,7 +764,7 @@ namespace eval punk::cap::handlers::templates { break } } - } + } if {$maybe ne "" && $not eq ""} { dict set result $k [dict get $itemdict $k] } @@ -755,12 +779,16 @@ namespace eval punk::cap::handlers::templates { } +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::cap::handlers::templates ::punk::cap::handlers::templates::class +} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { variable pkg punk::cap::handlers::templates variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm index ed4b22e4..675f42b0 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm @@ -19,7 +19,7 @@ #[manpage_begin punkshell_module_punk::char 0 0.1.0] #[copyright "2024"] #[titledesc {character-set and unicode utilities}] [comment {-- Name section and table of contents description --}] -#[moddesc {character-set nad unicode}] [comment {-- Description at end of page heading --}] +#[moddesc {character-set nad unicode}] [comment {-- Description at end of page heading --}] #[require punk::char] #[keywords module encodings] #[description] @@ -49,11 +49,11 @@ #*** !doctools #[item] [package {overtype}] -#[para] - +#[para] - #[item] [package {textblock}] -#[para] - +#[para] - #[item] [package console] -#[para] - +#[para] - package require Tcl 8.6- #dependency on tcllib not ideal for bootstrapping as punk::char is core to many features.. (textutil::wcswidth is therefore included in bootsupport/include_modules.config) review @@ -92,20 +92,20 @@ tcl::namespace::eval punk::char { #just the 7-bit ascii. use [page ascii] for the 8-bit layout proc ascii {} {return { 00 NUL 01 SOH 02 STX 03 ETX 04 EOT 05 ENQ 06 ACK 07 BEL - 08 BS 09 HT 0a LF 0b VT 0c FF 0d CR 0e SO 0f SI + 08 BS 09 HT 0a LF 0b VT 0c FF 0d CR 0e SO 0f SI 10 DLE 11 DC1 12 DC2 13 DC3 14 DC4 15 NAK 16 SYN 17 ETB - 18 CAN 19 EM 1a SUB 1b ESC 1c FS 1d GS 1e RS 1f US - 20 SP 21 ! 22 " 23 # 24 $ 25 % 26 & 27 ' - 28 ( 29 ) 2a * 2b + 2c , 2d - 2e . 2f / - 30 0 31 1 32 2 33 3 34 4 35 5 36 6 37 7 - 38 8 39 9 3a : 3b ; 3c < 3d = 3e > 3f ? - 40 @ 41 A 42 B 43 C 44 D 45 E 46 F 47 G - 48 H 49 I 4a J 4b K 4c L 4d M 4e N 4f O - 50 P 51 Q 52 R 53 S 54 T 55 U 56 V 57 W - 58 X 59 Y 5a Z 5b [ 5c \ 5d ] 5e ^ 5f _ - 60 ` 61 a 62 b 63 c 64 d 65 e 66 f 67 g - 68 h 69 i 6a j 6b k 6c l 6d m 6e n 6f o - 70 p 71 q 72 r 73 s 74 t 75 u 76 v 77 w + 18 CAN 19 EM 1a SUB 1b ESC 1c FS 1d GS 1e RS 1f US + 20 SP 21 ! 22 " 23 # 24 $ 25 % 26 & 27 ' + 28 ( 29 ) 2a * 2b + 2c , 2d - 2e . 2f / + 30 0 31 1 32 2 33 3 34 4 35 5 36 6 37 7 + 38 8 39 9 3a : 3b ; 3c < 3d = 3e > 3f ? + 40 @ 41 A 42 B 43 C 44 D 45 E 46 F 47 G + 48 H 49 I 4a J 4b K 4c L 4d M 4e N 4f O + 50 P 51 Q 52 R 53 S 54 T 55 U 56 V 57 W + 58 X 59 Y 5a Z 5b [ 5c \ 5d ] 5e ^ 5f _ + 60 ` 61 a 62 b 63 c 64 d 65 e 66 f 67 g + 68 h 69 i 6a j 6b k 6c l 6d m 6e n 6f o + 70 p 71 q 72 r 73 s 74 t 75 u 76 v 77 w 78 x 79 y 7a z 7b { 7c | 7d } 7e ~ 7f DEL }} @@ -124,7 +124,7 @@ tcl::namespace::eval punk::char { } elseif {[tcl::string::length $v] == 0} { set v " " } - append out "$k $v " + append out "$k $v " if {$i > 0 && $i % 8 == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -143,7 +143,7 @@ tcl::namespace::eval punk::char { set out "" append out [page dingbats] \n set unicode_dict [charset_dictget Dingbats] - + append out " " set i 1 tcl::dict::for {k charinfo} $unicode_dict { @@ -155,7 +155,7 @@ tcl::namespace::eval punk::char { } else { set displayv $char } - append out "$k $displayv " + append out "$k $displayv " if {$i > 0 && $i % 8 == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -205,7 +205,7 @@ tcl::namespace::eval punk::char { tcl::dict::lappend d $encname $mname } } - } + } foreach enc [lsort $encnames] { set mime_enc [${encmimens}::mapencoding $enc] if {$mime_enc ne ""} { @@ -236,7 +236,7 @@ tcl::namespace::eval punk::char { tailcall page $encname {*}$args } - #This will not display for example, c0 glyphs for cp437 + #This will not display for example, c0 glyphs for cp437 # we could use the punk::ansi::cp437_map dict - but while that might be what some expect to see - it would probably be too much magic for this function - which is intended to align more with what Tcl's encoding convertfrom/to actually does. # for nonprinting members of the page, 2 and 3 letter codes are used rather than unicode visualisation replacements or even unicode equivalent replacements known to be appropriate for the page proc page {encname args} { @@ -255,7 +255,7 @@ tcl::namespace::eval punk::char { #set d_ascii [pagedict_raw ascii] set d_ascii [basedict] - set d_asciiposn [lreverse $d_ascii] ;#values should be unique except for "???". We are mainly interested in which ones have display-names e.g cr csi + set d_asciiposn [lreverse $d_ascii] ;#values should be unique except for "???". We are mainly interested in which ones have display-names e.g cr csi #The results of this are best seen by comparing the ebcdic and ascii pages set d_page [pagedict_raw $encname] @@ -285,7 +285,7 @@ tcl::namespace::eval punk::char { set displayv $bytedisplay } else { if {[tcl::string::length $rawchar] == 0} { - set displayv " " + set displayv " " } else { #presumed 1 set displayv " $rawchar " @@ -294,7 +294,7 @@ tcl::namespace::eval punk::char { } } - append out "$k $displayv " + append out "$k $displayv " if {$i > 0 && $i % $cols == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -318,7 +318,7 @@ tcl::namespace::eval punk::char { set outchar [encoding convertfrom $encpage $ch] } else { #here we will use \0xFFFD instead of our replacement string ??? - as the name pagechar implies always returning a single character. REVIEW. - set outchar $::punk::char::invalid_display_char + set outchar $::punk::char::invalid_display_char } return $outchar } @@ -348,7 +348,7 @@ tcl::namespace::eval punk::char { #set outchar [encoding convertto $encpage [format %c $num]] set outchar [format %c $num] } else { - set outchar $::punk::char::invalid_display_char + set outchar $::punk::char::invalid_display_char } return $outchar } @@ -381,7 +381,7 @@ tcl::namespace::eval punk::char { } proc pagedict_raw {encname} { - variable invalid ;# ="???" + variable invalid ;# ="???" set encname [encname $encname] set d [tcl::dict::create] for {set i 0} {$i < 256} {incr i} { @@ -409,7 +409,7 @@ tcl::namespace::eval punk::char { tcl::dict::set d $k [tcl::dict::get $a128 $k] } else { # - tcl::dict::set d $k $invalid + tcl::dict::set d $k $invalid } if {$i <=32} { @@ -457,7 +457,7 @@ tcl::namespace::eval punk::char { } return $d } - + proc basedict {} { #this gives same result independent of current value of 'encoding system' set d [tcl::dict::create] @@ -529,10 +529,10 @@ tcl::namespace::eval punk::char { return $d } - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- # encoding convertfrom & encoding convertto can be somewhat confusing to think about. (Need to think in reverse.) # e.g encoding convertto dingbats will output something that doesn't look dingbatty on screen. - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- #must use Tcl instead of tcl (at least for 8.6) if {![package vsatisfies [package present Tcl] 8.7-]} { proc encodable "s {enc [encoding system]}" { @@ -552,16 +552,29 @@ tcl::namespace::eval punk::char { string eq $s [encoding convertto $encname [encoding convertfrom $encname $s]] } } else { + #review - use -profile? proc encodable "s {enc [encoding system]}" { set encname [encname $enc] - string eq $s [encoding convertfrom $encname [encoding convertto $encname $s]] + if {![catch { + string eq $s [encoding convertfrom $encname [encoding convertto $encname $s]] + } result]} { + return $result + } else { + return 0 + } } proc decodable "s {enc [encoding system]}" { set encname [encname $enc] - string eq $s [encoding convertto $encname [encoding convertfrom $encname $s]] + if {![catch { + string eq $s [encoding convertto $encname [encoding convertfrom $encname $s]] + } result]} { + return $result + } else { + return 0 + } } } - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- proc test_japanese {{encoding jis0208}} { #A very basic test of 2char encodings such as jis0208 set yatbun 日本 ;# encoding convertfrom jis0208 F|K\\ @@ -571,7 +584,7 @@ tcl::namespace::eval punk::char { set ebun [encoding convertto $encoding $bun] puts "$encoding encoded: ${eyat} ${ebun}" puts "reencoded: [encoding convertfrom $encoding $eyat] [encoding convertfrom $encoding $ebun]" - return $yatbun + return $yatbun } proc test_grave {} { set g [format %c 0x300] @@ -587,6 +600,48 @@ tcl::namespace::eval punk::char { puts stdout \n puts stdout "cursor position immediately after outputing 3 bytes (xyz): $cursorposn" } + proc test_zalgo {} { + #from: https://github.com/jameslanska/unicode-display-width/blob/5e28d94c75e8c421a87199363b85c90dc37125b8/docs/unicode_background.md + #see: https://lingojam.com/ZalgoText + puts stdout "44 chars long - 9 graphemes - 9 columns wide" + + set str "Ẓ̌á̲l͔̝̞̄̑͌g̖̘̘̔̔͢͞͝o̪̔T̢̙̫̈̍͞e̬͈͕͌̏͑x̺̍ṭ̓̓ͅ" + + } + + proc test_zalgo2 {} { + + # ------------------------ + + + + set str "Z̸̢͉̣͔̭̪͙̖̳̘͈͍̤̩̟͈͈͕̯̅̏̆̓̌́́͌̿̕ͅą̷̦̤̫̩͕̥̐̎̓́́̂̀͆́̔̄̈́̏̌́̆͜͜͝͠l̴̩̙̺͚̟͇͖͔͕̹̟͌̈́̄̇́̉̋̕̚͜͠͠g̸͇̩͔̺̝̗̥̖̙̑̈́̈́̿̾̌͌͊̈̀͊̑̇̑͌̍̅̌͊͜͠͝ǫ̴̢̧͎͔̞̤̻̱̮̬͕̗̭͍̣̠̳̆̀̋̓͒̾̄͜͝͠͝T̴̛͉̬̋́̈́̈́̓͗̍̏̔̈̋̀͐̓̎̅̚̕͠͝͝ê̵̖̖̈͊̔̓̔̐̓̃͊̋͋̎͂͋̕x̴̡͎͖̼͎̦͎̲̪̘̺̯̲̬̮̥̼̰͌̃͜ͅt̶̛̘͎̰̔͐͌́̈́͊͗͌̅͂̐̆͌̀͂͘" + + + + + # ------------------------ + } + + proc test_zalgo3 {} { + + # ------------------------ + + + + + set str "Ẕ̸̢̼̺̜̰̣̣̖̭̜͓͖̺̥̼̠͙͙̟̥̟̠̤̫͍̠̤̮͚̝̜̙͈̦̙̩̹̙̜̩̦͔͕̈̃̅̇̈́͂̇̽̈́́́́̎͊̂̑̋͆̔̾͋̚͜ͅã̵̛̪̽̎̃͑̒̇͋͂̽̃̍͊̀̈̊̊̔̊̆̈́͗͑͗̽̄̋͗̄͌̑͊͝͝͠ͅl̵̢͇̖͉͖̝̹̜̞͓͎͍͈̞̱̙͙̦̪͔̱̮͈͉̼͎̭̝̯͇͚̺̟̱͙̳̰̙͚͖̝̫͙̎̅̃͆̈́̋̌̔̋̋͗̈́̔̐͆̈́̓̾̄̀́̏́͒̆̌͒̈́̈́̾̏̀͜͝g̸̖͂͋̊͗̈́̓̆̈̋̒͐̕o̶̧̢͓̲̗̠̘͕̦̤̹̗͉̰͔̯͓̭̹̻͔͇̯̜̙̍̂̃̃̀̓͌̒͊̊̋̒̿̿̌͐̄͗̾̕͝T̶̛̳̜̰͍̹̻̫̠̱̼̼̙̆̑̾̾͛́́̿͋͌̎̀̀̽̆͌̽̂̈̇̅̇̃́̿͗̾͒̎͊̑̾͝͠ȩ̸̢̨̛̛̛̭͔͎͇̫͎͈̲̻̙͕͎̣͈̩̺̗͖͙͇͌͐̒̎͐̓́̉́͐̓̐͌̅̊͋͑̈́͗͑̏̕͜͜͝ͅx̸̧̧̛̖̣̥̘͎͎̳̭̙̦̝͖̝̮̱̹̯̺̙̩̯̮͖̻̰͓̰̩͇̥̑͌̊̐̉̏͆̓̑̎̊̓͒̂̄̆͆̀̊̄̈̽͐͛̏͊̓̌͑́̎̈́̍̈́̊͗̉̋͆̿̊͘͜͜͝͝ͅͅͅt̵̡̨̜̘͎̦͚̠̗̺͉̼̠̲̠͙̺̹̗̲̏̈́̂̚͜͜͝ͅ" + + + + + + # ------------------------ + + } + + + proc test_farmer {} { #an interesting article re grapheme clustering problems in terminals https://mitchellh.com/writing/grapheme-clusters-in-terminals #(similar to the problem with grave accent rendering width that the test_grave proc is written for) @@ -607,17 +662,29 @@ tcl::namespace::eval punk::char { puts stdout "farmer2 with no joiner codes: \\U0001f9d1\\U001f33e : $farmer2" package require punk::console + puts stdout \n puts stdout "#2--5---9---C---" puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1 - puts -nonewline "${farmer1}";set cursorposn [punk::console::get_cursor_pos] - puts stdout \n - puts stdout "cursor position immediately after outputing farmer1 (expecting 1 glyph 2 wide) : $cursorposn" + puts -nonewline "${farmer1}";set cursorposn [punk::console::get_cursor_pos_list] + puts stdout "\ncursor position immediately after outputing farmer1 (expecting 1 glyph 2 wide) : cursor at col [lindex $cursorposn 1]" + if {[lindex $cursorposn 1] eq "3"} { + puts stdout "[a+ green]OK[a]" + } else { + puts stdout "[a+ red]ERR - expected cursor position to be 3 after emitting farmer1[a]" + } + puts stdout "----------------" puts stdout "#2--5---9---C---" - puts -nonewline "${farmer2}";set cursorposn [punk::console::get_cursor_pos] - puts stdout \n - puts stdout "cursor position immediately after outputing farmer2 (expecting 2 glyphs 4 wide in total): $cursorposn" + puts -nonewline "${farmer2}";set cursorposn [punk::console::get_cursor_pos_list] + puts stdout "\ncursor position immediately after outputing farmer2 (expecting 2 glyphs 4 wide in total): cursor at col [lindex $cursorposn 1]" + if {[lindex $cursorposn 1] eq "5"} { + puts stdout "[a+ green]OK[a]" + } else { + puts stdout "[a+ red]ERR - expected cursor position to be 5 after emitting farmer2[a]" + } + puts stdout "----------------" - return [list $farmer1 $farmer2] + puts "returning farmer1 - should be single glyph" + return $farmer1 } #G0 Sets Sequence G1 Sets Sequence Meaning @@ -625,7 +692,7 @@ tcl::namespace::eval punk::char { #ESC ( B ESC ) B ASCII Set #ESC ( 0 ESC ) 0 Special Graphics #ESC ( 1 ESC ) 1 Alternate Character ROM Standard Character Set - #ESC ( 2 ESC ) 2 Alternate Character ROM Special Graphic + #ESC ( 2 ESC ) 2 Alternate Character ROM Special Graphic # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # Unicode character sets - some hardcoded - some loadable from data files @@ -633,7 +700,7 @@ tcl::namespace::eval punk::char { variable charinfo [tcl::dict::create] variable charsets [tcl::dict::create] - + # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # Aggregate character sets (ones that pick various ranges from underlying unicode ranges) # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -674,7 +741,7 @@ tcl::namespace::eval punk::char { } # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # Unicode ranges + # Unicode ranges # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- tcl::dict::set charsets "greek" [list ranges [list {start 880 end 1023} {start 7936 end 8191}] description "Greek and Coptic" settype "other"] @@ -908,9 +975,9 @@ tcl::namespace::eval punk::char { variable charset_extents_rangenames ;# dict keyed on start,end pointing to list of 2-tuples {setname rangeindex_within_set} #build 2 indexes for each range.(charsets are not just unicode blocks so can have multiple ranges) #Note that a range could be as small as a single char (startpoint = endpoint) so there can be many ranges with same start and end if charsets use some of the same subsets. - #as each charset_extents_startpoins,charset_extents_endpoints is built - the associated range name and index is appended to the rangenames dict - #startpoints - key is startpoint of a range, value is list of endpoints one for each range starting at this startpoint-key - #endpoints - key is endpoint of a range, value is list of startpoints one for each range ending at this endpoint-key + #as each charset_extents_startpoins,charset_extents_endpoints is built - the associated range name and index is appended to the rangenames dict + #startpoints - key is startpoint of a range, value is list of endpoints one for each range starting at this startpoint-key + #endpoints - key is endpoint of a range, value is list of startpoints one for each range ending at this endpoint-key proc _build_charset_extents {} { variable charsets variable charset_extents_startpoints @@ -928,7 +995,7 @@ tcl::namespace::eval punk::char { set end [tcl::dict::get [lindex $ranges 0] end] if {![tcl::dict::exists $charset_extents_startpoints $start] || $end ni [tcl::dict::get $charset_extents_startpoints $start]} { #assertion if end wasn't in startpoits list - then start won't be in endpoints list - tcl::dict::lappend charset_extents_startpoints $start $end + tcl::dict::lappend charset_extents_startpoints $start $end tcl::dict::lappend charset_extents_endpoints $end $start } tcl::dict::lappend charset_extents_rangenames ${start},${end} [list $setname 1] @@ -956,14 +1023,14 @@ tcl::namespace::eval punk::char { #no need to sort charset_extents_rangenames - lookup only done using dict methods return [tcl::dict::size $charset_extents_startpoints] } - _build_charset_extents ;#rebuilds for all charsets + _build_charset_extents ;#rebuilds for all charsets #nerdfonts are within the Private use E000 - F8FF range proc load_nerdfonts {} { variable charsets variable charinfo package require fileutil - set ver [package provide punk::char] + set ver [package provide punk::char] if {$ver ne ""} { set ifneeded [package ifneeded punk::char [package provide punk::char]] #puts stderr "punk::char ifneeded script: $ifneeded" @@ -971,7 +1038,7 @@ tcl::namespace::eval punk::char { set basedir [file dirname [lindex $sourceinfo end]] } else { #review - will only work at package load time - set scr [info script] + set scr [info script] if {$scr eq ""} { error "load_nerdfonts unable to determine package folder" } @@ -981,7 +1048,7 @@ tcl::namespace::eval punk::char { set fname [file join $pkg_data_dir nerd-fonts-glyph-list.txt] if {[file exists $fname]} { #puts stderr "load_nerdfonts loading $fname" - set data [fileutil::cat -translation binary $fname] + set data [fileutil::cat -translation binary $fname] set short_seen [tcl::dict::create] set current_set_range [tcl::dict::create] set filesets_loading [list] @@ -999,7 +1066,7 @@ tcl::namespace::eval punk::char { dict unset charset $setname } set newrange [list start $dec end $dec] - tcl::dict::set current_set_range $setname $newrange + tcl::dict::set current_set_range $setname $newrange tcl::dict::set charsets $setname [list ranges [list $newrange] description "nerd fonts $rawsetname" settype "nerdfonts privateuse"] lappend filesets_loading $setname @@ -1013,13 +1080,13 @@ tcl::namespace::eval punk::char { #overwrite last ranges element set rangelist [lrange [tcl::dict::get $charsets $setname ranges] 0 end-1] lappend rangelist [tcl::dict::get $current_set_range $setname] - tcl::dict::set charsets $setname ranges $rangelist + tcl::dict::set charsets $setname ranges $rangelist } else { #new range for set tcl::dict::set current_set_range $setname start $dec tcl::dict::set current_set_range $setname end $dec set rangelist [tcl::dict::get $charsets $setname ranges] - lappend rangelist [tcl::dict::get $current_set_range $setname] + lappend rangelist [tcl::dict::get $current_set_range $setname] tcl::dict::set charsets $setname ranges $rangelist } @@ -1063,7 +1130,7 @@ tcl::namespace::eval punk::char { proc package_base {} { #assume punk::char is in .tm form and we can use the package provide statement to determine base location - #review + #review set pkgver [package present punk::char] set pkginfo [package ifneeded punk::char $pkgver] set tmfile [lindex $pkginfo end] @@ -1089,7 +1156,7 @@ tcl::namespace::eval punk::char { if {[tcl::dict::exists $dictValue {*}$keys]} { return [tcl::dict::get $dictValue {*}$keys] } else { - return [lindex $args end] + return [lindex $args end] } } } @@ -1114,7 +1181,7 @@ tcl::namespace::eval punk::char { } puts "ok.. loading" set fd [open $file r] - fconfigure $fd -translation binary + chan configure $fd -translation binary set data [read $fd] close $fd set block_count 0 @@ -1126,7 +1193,7 @@ tcl::namespace::eval punk::char { if {[set pcolon [tcl::string::first ";" $ln]] > 0} { set lhs [tcl::string::trim [tcl::string::range $ln 0 $pcolon-1]] set name [tcl::string::trim [tcl::string::range $ln $pcolon+1 end]] - set lhsparts [split $lhs .] + set lhsparts [split $lhs .] set start [lindex $lhsparts 0] set end [lindex $lhsparts end] #puts "$start -> $end '$name'" @@ -1140,9 +1207,9 @@ tcl::namespace::eval punk::char { return $block_count } - #unicode scripts + #unicode scripts - #unicode UnicodeData.txt + #unicode UnicodeData.txt @@ -1158,8 +1225,8 @@ tcl::namespace::eval punk::char { # -- --- #A = Ambiguous - All characters that can be sometimes wide and sometimes narrow. (wide in east asian legacy sets, narrow in non-east asian usage) (private use chars considered ambiguous) #F = East Asian Full-width - #H = East Asian Half-width - #N = Not east Asian (Neutral) - all other characters. (do not occur in legacy East Asian character sets) - treated like Na + #H = East Asian Half-width + #N = Not east Asian (Neutral) - all other characters. (do not occur in legacy East Asian character sets) - treated like Na #Na = East Asian Narrow - all other characters that are always narrow and have explicit full-width counterparts (e.g includes all of ASCII) #W = East Asian Wide - all other characters that are always wide (Occur only in the context of Eas Asian Typography) # -- --- @@ -1179,6 +1246,10 @@ tcl::namespace::eval punk::char { return [charset_dict "Box Drawing"] } + proc char_hex {char} { + return [format %08x [scan $char %c]] + } + proc char_info_hex {hex args} { set hex [tcl::string::map [list _ ""] $hex] if {[tcl::string::is xdigit -strict $hex]} { @@ -1233,7 +1304,7 @@ tcl::namespace::eval punk::char { set initial_fields $known_fields if {"testwidth" ni $opt_fields} { if {"testwidth" ni $opt_except} { - lappend opt_except testwidth + lappend opt_except testwidth } } if {"char" ni $opt_fields} { @@ -1298,13 +1369,13 @@ tcl::namespace::eval punk::char { #testwidth is one of the main ones likely to be worthwhile excluding as querying the console via ansi takes time set existing_testwidth "" if {[tcl::dict::exists $charinfo $dec_char testwidth]} { - set existing_testwidth [tcl::dict::get $charinfo $dec_char testwidth] + set existing_testwidth [tcl::dict::get $charinfo $dec_char testwidth] } if {$existing_testwidth eq ""} { #no cached data - do expensive cursor-position test (Note this might not be 100% reliable - terminals lie e.g if ansi escape sequence has set to wide printing.) set char [format %c $dec_char] set chwidth [char_info_testwidth $char] - + tcl::dict::set returninfo testwidth $chwidth #cache it. todo - -verify flag to force recalc in case font/terminal changed in some way? tcl::dict::set charinfo $dec_char testwidth $chwidth @@ -1316,10 +1387,10 @@ tcl::namespace::eval punk::char { set char [format %c $dec_char] tcl::dict::set returninfo char $char } - memberof { + memberof { #memberof takes in the order of a few hundred microseconds if a simple scan of all ranges is taken - possibly worthwhile caching/optimising #note that memberof is not just unicode blocks - but scripts and other non-contiguous sets consisting of multiple ranges - some of which may include ranges of a single character. (e.g WGL4) - #This means there probably isn't a really efficient means of calculating membership other than scanning all the defined ranges. + #This means there probably isn't a really efficient means of calculating membership other than scanning all the defined ranges. #We could potentially populate it using a side-thread - but it seems reasonable to just cache result after first use here. #some efficiency could also be gained by pre-calculating the extents for each charset which isn't a simple unicode block. (and perhaps sorting by max char) set memberof [list] @@ -1364,7 +1435,7 @@ tcl::namespace::eval punk::char { set splen [tcl::dict::size $charset_extents_startpoints] set eplen [tcl::dict::size $charset_extents_endpoints] set s [lsearch -bisect -integer $skeys $dec] - set s_at_or_below [lrange $skeys 0 $s] + set s_at_or_below [lrange $skeys 0 $s] set e_of_s [list] foreach sk $s_at_or_below { lappend e_of_s {*}[tcl::dict::get $charset_extents_startpoints $sk] @@ -1401,16 +1472,16 @@ tcl::namespace::eval punk::char { set eps [list] } - + return [tcl::dict::create startpoints $splen endpoints $eplen midpoint [expr {floor($eplen/2)}] posn $e lhs_endpoints_to_check "[llength $reduced_endpoints]/[llength $e_of_s]=[llength $sps]ranges" rhs_startpoints_to_check "[llength $reduced_startpoints]/[llength $s_of_e]=[llength $eps]"] } #for just a few extra sets such as wgl4 and unicode blocks loaded - this gives e.g 5x + better performance than the simple search above, and up to twice as slow for tcl 8.6 #performance biased towards lower numbered characters (which is not too bad in the context of unicode) #todo - could be tuned to perform better at end by assuming a fairly even distribution of ranges - and so searching startpoint ranges first for items left of middle, endpoint ranges first for items right of middle - #review with scripts loaded and more defined ranges.. + #review with scripts loaded and more defined ranges.. #This algorithm supports arbitrary overlapping ranges and ranges with same start & endpoints #Should be much better than O(n) for n sets except for pathological case of member of all or nearly-all intervals ? - #review - compare with 'interval tree' algorithms. + #review - compare with 'interval tree' algorithms. proc char_info_dec_memberof {dec} { variable charset_extents_startpoints variable charset_extents_endpoints @@ -1492,7 +1563,7 @@ tcl::namespace::eval punk::char { set matchcount 0 foreach glob $and_globs { if {[tcl::string::match -nocase $glob $s] || [tcl::string::match -nocase $glob $d]} { - incr matchcount + incr matchcount } } if {$matchcount == [llength $and_globs]} { @@ -1524,12 +1595,12 @@ tcl::namespace::eval punk::char { } - #non-overlapping unicode blocks + #non-overlapping unicode blocks proc char_blocks {{name_or_glob *}} { variable charsets #todo - more efficient datastructures? if {![regexp {[?*]} $name_or_glob]} { - #no glob - just retrieve it + #no glob - just retrieve it if {[tcl::dict::exists $charsets $name_or_glob]} { if {[tcl::dict::get $charsets $name_or_glob settype] eq "block"} { return [tcl::dict::create $name_or_glob [tcl::dict::get $charsets $name_or_glob]] @@ -1559,7 +1630,7 @@ tcl::namespace::eval punk::char { proc charset_names {{name_or_glob *}} { variable charsets if {![regexp {[?*]} $name_or_glob]} { - #no glob - just retrieve it + #no glob - just retrieve it if {[tcl::dict::exists $charsets $name_or_glob]} { return [list $name_or_glob] } @@ -1570,7 +1641,7 @@ tcl::namespace::eval punk::char { } } else { if {$name_or_glob eq "*"} { - return [lsort [tcl::dict::keys $charsets]] + return [lsort [tcl::dict::keys $charsets]] } #tcl::dict::keys $dict doesn't have option for case insensitive searches return [lsort [lsearch -all -inline -nocase [tcl::dict::keys $charsets] $name_or_glob]] @@ -1584,7 +1655,7 @@ tcl::namespace::eval punk::char { variable charsets #dictionary sorting of the keys is slow! - we should obviously store it in sorted order instead of sorting entire list on retrieval - or just sort results #set sortedkeys [lsort -increasing -dictionary [tcl::dict::keys $charsets]] ;#NOTE must use -dictionary to use -sorted flag below - set sortedkeys [lsort -increasing [tcl::dict::keys $charsets]] + set sortedkeys [lsort -increasing [tcl::dict::keys $charsets]] if {$namesearch eq "*"} { return $sortedkeys } @@ -1593,7 +1664,7 @@ tcl::namespace::eval punk::char { return [lsearch -all -inline -nocase $sortedkeys $namesearch] ;#no point using -sorted flag when -all is used } else { #return [lsearch -sorted -inline -nocase $sortedkeys $namesearch] ;#no globs - bails out earlier if -sorted? - return [lsearch -inline -nocase $sortedkeys $namesearch] ;#no globs + return [lsearch -inline -nocase $sortedkeys $namesearch] ;#no globs } } proc charsets {{namesearch *}} { @@ -1667,7 +1738,7 @@ tcl::namespace::eval punk::char { set opt_ansi [tcl::dict::get $opts -ansi] set opt_lined [tcl::dict::get $opts -lined] # -- --- --- --- - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} if {$opt_ansi} { set a1 [a BLACK white bold] @@ -1697,7 +1768,7 @@ tcl::namespace::eval punk::char { } set i 1 append out \n $prefix $charsetname - append out \n + append out \n set marker_line $prefix set line $prefix @@ -1776,7 +1847,7 @@ tcl::namespace::eval punk::char { } else { set charset_dict [charset_dictget $charsetname] } - + set col_items_short [list] set col_items_desc [list] tcl::dict::for {k inf} $charset_dict { @@ -1802,7 +1873,7 @@ tcl::namespace::eval punk::char { return $out } - #use console cursor movements to test and cache the column-width of each char in the set of characters returned by the search criteria + #use console cursor movements to test and cache the column-width of each char in the set of characters returned by the search criteria proc charset_calibrate {namesearch args} { variable charsets variable charinfo @@ -1838,7 +1909,7 @@ tcl::namespace::eval punk::char { set twidth [tcl::dict::get $charinfo $dec testwidth] } if {$twidth eq ""} { - #puts -nonewline stdout "." ;#this + #puts -nonewline stdout "." ;#this set width [char_info_testwidth $ch] ;#based on console test rather than unicode props tcl::dict::set charinfo $dec testwidth $width } else { @@ -1854,10 +1925,10 @@ tcl::namespace::eval punk::char { #maint warning - also in overtype! #intended for single grapheme - but will work for multiple - #cannot contain ansi or newlines + #cannot contain ansi or newlines #(a cache of ansifreestring_width calls - as these are quite regex heavy) #review - effective memory leak on longrunning programs if never cleared - #tradeoff in fragmenting cache and reducing efficiency vs ability to clear in a scoped manner + #tradeoff in fragmenting cache and reducing efficiency vs ability to clear in a scoped manner proc grapheme_width_cached {ch {key ""}} { variable grapheme_widths #if key eq "*" - we won't be able to clear that cache individually. Perhaps that's ok @@ -1899,15 +1970,127 @@ tcl::namespace::eval punk::char { tailcall ansifreestring_width $text } - #faster than textutil::wcswidth (at least for string up to a few K in length) + #todo - consider disallowing/erroring out when \r \n in string? + # - tab/vtab? + # - compare with wcswidth returning -1 for entire string containing such in python,perl proc wcswidth {string} { - set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]] + #faster than textutil::wcswidth (at least for string up to a few K in length) + #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) + #Tcl initial evaluation stack size is 2000 (? review) + #REVIEW - when we cater for grapheme clusters - we can't just split the string at arbitrary points like this!! + set chunksize 2000 + set chunks_required [expr {int(ceil([tcl::string::length $string] / double($chunksize)))}] + set width 0 + set startidx 0 + set endidx [expr {$startidx + $chunksize -1}] + for {set i 0} {$i < $chunks_required} {incr i} { + set chunk [tcl::string::range $string $startidx $endidx] + + set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]] + foreach c $codes { + if {$c <= 255 && !($c < 31 || $c == 127)} { + #review - non-printing ascii? why does textutil::wcswidth report 1 ?? + #todo - compare with python or other lang wcwidth + incr width + } elseif {$c < 917504 || $c > 917631} { + #TODO - various other joiners and non-printing chars + set w [textutil::wcswidth_char $c] + if {$w < 0} { + return -1 + } else { + incr width $w + } + } + } + incr startidx $chunksize + incr endidx $chunksize + } + return $width + } + + + + # ------------------------------------------------------------------------------------------------------ + #test + # ------------------------------------------------------------------------------------------------------ + proc grapheme_split_tk {string} { + if {![regexp "\[\uFF-\U10FFFF\]" $string]} { + #only ascii (7 or 8 bit) - no joiners or unicode + return [split $string {}] + } + package require tk + set i 0 + set graphemes [list] + while {$i < [tcl::string::length $string]} { + set aftercluster [tk::endOfCluster $string $i] + lappend graphemes [string range $string $i $aftercluster-1] + set i $aftercluster + } + return $graphemes + } + proc wcswidth_clustered {string} { + package require tk set width 0 - foreach c $codes { - if {$c <= 255} { - incr width + set i 0 + if {![regexp "\[\uFF-\U10FFFF\]" $string]} { + return [punk::char::wcswidth_unclustered $string] ;#still use our wcswidth to account for non-printable ascii + } + while {$i < [tcl::string::length $string]} { + set aftercluster [tk::endOfCluster $string $i] + set g [string range $string $i $aftercluster-1] + if {$aftercluster > ($i + 1)} { + #review - proper way to determine screen width (columns occupied) of a cluster?? + #according to this: + #https://lib.rs/crates/unicode-display-width + #for each grapheme - if any of the code points in the cluster have an east asian width of 2, + #The entire grapheme width is 2 regardless of how many code points constitute the grapheme + set gw 1 + foreach ch [split $g ""] { + if {[punk::char::wcswidth_single $ch] == 2} { + set gw 2 + break + } + } + incr width $gw + + #if {[string first \u200d $g] >=0} { + # incr width 2 + #} else { + # #other joiners??? + # incr width [wcswidth_unclustered $g] + #} } else { - set w [textutil::wcswidth_char $c] + incr width [wcswidth_unclustered $g] + } + set i $aftercluster + } + + return $width + } + proc wcswidth_single {char} { + scan $char %c dec + if {$dec <= 255 && !($dec < 31 || $dec == 127)} { + #review - non-printing ascii? why does textutil::wcswidth report 1 ?? + #todo - compare with python or other lang wcwidth + return 1 + } elseif {$dec < 917504 || $dec > 917631} { + #TODO - various other joiners and non-printing chars + return [textutil::wcswidth_char $dec] ;#note textutil::wcswidth_char takes a decimal codepoint! + #may return -1 - REVIEW + } + return 0 + } + proc wcswidth_unclustered1 {string} { + set width 0 + foreach c [split $string {}] { + scan $c %c dec + if {$dec <= 255 && !($dec < 31 || $dec == 127)} { + #review - non-printing ascii? why does textutil::wcswidth report 1 ?? + #todo - compare with python or other lang wcwidth + incr width + } elseif {$dec < 917504 || $dec > 917631} { + #TODO - various other joiners and non-printing chars + set w [textutil::wcswidth_char $dec] ;#takes decimal codepoint if {$w < 0} { return -1 } else { @@ -1917,23 +2100,76 @@ tcl::namespace::eval punk::char { } return $width } - #faster than textutil::wcswidth (at least for string up to a few K in length) - proc wcswidth1 {string} { + #todo - consider disallowing/erroring out when \r \n in string? + # - tab/vtab? + # - compare with wcswidth returning -1 for entire string containing such in python,perl + proc wcswidth_unclustered {string} { + #faster than textutil::wcswidth (at least for string up to a few K in length) + #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) + #Tcl initial evaluation stack size is 2000 (? review) + #we can only split the string at arbitrary points like this because we are specifically dealing with input that has no clusters!. + set chunksize 2000 + set chunks_required [expr {int(ceil([tcl::string::length $string] / double($chunksize)))}] + set width 0 + set startidx 0 + set endidx [expr {$startidx + $chunksize -1}] + for {set i 0} {$i < $chunks_required} {incr i} { + set chunk [tcl::string::range $string $startidx $endidx] + + set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]] + foreach dec $codes { + if {$dec <= 255 && !($dec < 31 || $dec == 127)} { + #review - non-printing ascii? why does textutil::wcswidth report 1 ?? + #todo - compare with python or other lang wcwidth + incr width + } elseif {$dec < 917504 || $dec > 917631} { + #TODO - various other joiners and non-printing chars + set w [textutil::wcswidth_char $dec] + if {$w < 0} { + return -1 + } else { + incr width $w + } + } + } + incr startidx $chunksize + incr endidx $chunksize + } + return $width + } + # ------------------------------------------------------------------------------------------------------ + + proc wcswidth0 {string} { + #faster than textutil::wcswidth (at least for string up to a few K in length) + #..but - 'scan' is horrible for 400K+ + #TODO set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]] set width 0 - foreach c $codes { - set w [textutil::wcswidth_char $c] - if {$w < 0} { - return -1 - } else { - incr width $w + foreach dec $codes { + #unicode Tags block zero width + if {$dec < 917504 || $dec > 917631} { + if {$dec <= 255} { + #review - non-printing ascii? why does textutil::wcswidth report 1 ?? + #todo - compare with python or other lang wcwidth + if {!($dec < 31 || $dec == 127)} { + incr width + } + } else { + #TODO - various other joiners and non-printing chars + set w [textutil::wcswidth_char $dec] ;#takes decimal codepoint + if {$w < 0} { + return -1 + } else { + incr width $w + } + } } } return $width } proc wcswidth2 {string} { set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]] - set widths [lmap c $codes {textutil::wcswidth_char $c}] + set widths [lmap dec $codes {textutil::wcswidth_char $dec}] if {-1 in $widths} { return -1 } @@ -1943,11 +2179,11 @@ tcl::namespace::eval punk::char { #prerequisites - no ansi escapes - no newlines - utf8 encoding assumed #review - what about \r \t \b ? #NO processing of \b - already handled in ansi::printing_length which then calls this - #this version breaks string into sequences of ascii vs unicode + #this version breaks string into sequences of ascii vs unicode proc ansifreestring_width {text} { #caller responsible for calling ansistrip first if text may have ansi codes - and for ensuring no newlines #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -1968,11 +2204,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] # -- --- --- --- --- --- --- @@ -1985,10 +2221,10 @@ tcl::namespace::eval punk::char { #for now - strip them out #ZWNJ \u200c should also be zero length - but as a 'non' joiner - it should add zero to the length - #ZWSP \u200b zero width space + #ZWSP \u200b zero width space #\uFFEFBOM/ ZWNBSP and others that should be zero width - #todo - work out proper way to mark/group zero width. + #todo - work out proper way to mark/group zero width. #set text [tcl::string::map [list \u200b "" \u200c "" \u200d "" \uFFEF ""] $text] set text [tcl::string::map [list \u200b "" \u200c "" \u200d ""] $text] @@ -2005,7 +2241,7 @@ tcl::namespace::eval punk::char { #c1 controls - first section of the Latin-1 Supplement block - all non-printable from a utf-8 perspective #some or all of these may have a visual representation in other encodings e.g cp855 seems to have 1 width for them all - #we are presuming that the text supplied has been converted from any other encoding to utf8 - so we don't need to handle that here + #we are presuming that the text supplied has been converted from any other encoding to utf8 - so we don't need to handle that here #they should also be unlikely to be present in an ansi-free string (as is a precondition for use of this function) set text [regsub -all {[\u0080-\u009f]+} $text ""] @@ -2016,7 +2252,8 @@ tcl::namespace::eval punk::char { # return [tcl::string::length $text] #} if {![regexp "\[\uFF-\U10FFFF\]" $text]} { - return [tcl::string::length $text] + #return [tcl::string::length $text] + return [punk::char::wcswidth $text] ;#still use our wcswidth to account for non-printable ascii } #split just to get the standalone character widths - and then scan for other combiners (?) - or scan for clusters first? @@ -2025,7 +2262,7 @@ tcl::namespace::eval punk::char { #set can_regex_high_unicode [tcl::string::match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] #tcl pre 2023-11 - braced high unicode regexes don't work #fixed in bug-4ed788c618 2023-11 - #set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only + #set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only #maintain unicode as sequences - todo - scan for grapheme clusters #set uc_sequences [punk::ansi::ta::_perlish_split "(?:\[\u0100-\U10FFFF\])+" $text] @@ -2039,7 +2276,7 @@ tcl::namespace::eval punk::char { #fall back to textutil::wcswidth (which doesn't for example handle diactricts/combiners so we can't use until these and other things such as \u200b and diacritics are already stripped/accounted for) #todo - find something that understands grapheme clusters - needed also for grapheme_split #use punk::char::wcswidth - faster than the string split in textutil::wcswidth but still uses textutil::wcswidth_char - incr len [wcswidth $uc] + incr len [punk::char::wcswidth $uc] } #todo - work out what to do with anomalies like grave combiner which print at different lengths on different terminals (fonts?) and for which cursor-query escape sequence lies. return $len @@ -2054,7 +2291,7 @@ tcl::namespace::eval punk::char { #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2075,11 +2312,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] #review @@ -2088,7 +2325,7 @@ tcl::namespace::eval punk::char { #ZWNJ \u0200c should also be zero length - but as a 'non' joiner - it should add zero to the length - #ZWSP \u0200b zero width space + #ZWSP \u0200b zero width space #we should only map control sequences to nothing after processing ones with length effects, such as \b (\x07f) or DEL \x1f @@ -2106,10 +2343,10 @@ tcl::namespace::eval punk::char { } #review - wcswidth should detect these - set re_ascii_fullwidth {[\uFF01-\uFF5e]} + set re_ascii_fullwidth {[\uFF01-\uFF5e]} set doublewidth_char_count 0 - set zerowidth_char_count 0 + set zerowidth_char_count 0 #split just to get the standalone character widths - and then scan for other combiners (?) #review #set can_regex_high_unicode [tcl::string::match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] @@ -2117,7 +2354,7 @@ tcl::namespace::eval punk::char { #fixed in bug-4ed788c618 2023-11 #set uc_sequences [regexp -all -inline -indices {[\u0100-\U10FFFF]} $text] #set uc_sequences [regexp -all -inline -indices "\[\u0100-\U10FFFF\]" $text] ;#e.g for string: \U0001f9d1abc\U001f525ab returns {0 0} {4 4} - set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only + set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only foreach c $uc_chars { if {[regexp $re_ascii_fullwidth $c]} { incr doublewidth_char_count @@ -2127,12 +2364,12 @@ tcl::namespace::eval punk::char { # b)- textutil::wcswidth_char seems to be east-asian-width based - and not a reliable indicator of 'character cells taken by the character when printed to the terminal' despite this statement in tclllib docs. #(character width is a complex context-dependent topic) # c) by checking for a cached console testwidth first - we make this function less deterministic/repeatable depending on whether console tests have been run. - # d) Upstream caching of grapheme_width may also lock in a result from whatever method was first employed here + # d) Upstream caching of grapheme_width may also lock in a result from whatever method was first employed here #Despite all this - the mechanism is hoped to give best effort consistency for terminals - #further work needed for combining emojis etc - which can't be done in a per character loop + #further work needed for combining emojis etc - which can't be done in a per character loop #todo - see if wcswidth does any of this. It is very slow for strings that include mixed ascii/unicode - so perhaps we can use a perlish_split # to process sequences of unicode. - #- and the user has the option to test character sets first if terminal position reporting gives better results + #- and the user has the option to test character sets first if terminal position reporting gives better results if {[char_info_is_testwidth_cached $c]} { set width [char_info_testwidth_cached $c] } else { @@ -2141,7 +2378,7 @@ tcl::namespace::eval punk::char { set width [textutil::wcswidth_char [scan $c %c]] } if {$width == 0} { - incr zerowidth_char_count + incr zerowidth_char_count } elseif {$width == 2} { incr doublewidth_char_count } @@ -2158,7 +2395,7 @@ tcl::namespace::eval punk::char { #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2179,11 +2416,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] #we should only map control sequences to nothing after processing ones with length effects, such as \b (\x07f) or DEL \x1f @@ -2200,7 +2437,7 @@ tcl::namespace::eval punk::char { return [tcl::string::length $text] } - #slow when ascii mixed with unicode (but why?) + #slow when ascii mixed with unicode (but why?) return [punk::char::wcswidth $text] } #This shouldn't be called on text containing ansi codes! @@ -2216,13 +2453,74 @@ tcl::namespace::eval punk::char { return [tcl::string::map $map $str] } + #todo - lookup from unicode tables + variable flags [dict create\ + AU \U1F1E6\U1F1FA\ + US \U1F1FA\U1F1F8\ + ZW \U1F1FF\U1F1FC + ] + variable rflags + dict for {k v} $flags { + dict set rflags $v $k + } + + + proc flag_from_ascii {code} { + variable flags + if {[regexp {^[A-Z]{2}$} $code]} { + if {[dict exists $flags $code]} { + return [dict get $flags $code] + } else { + error "unsupported flags code: $code" + } + } else { + #try as subregion + #e.g gbeng,gbwls,gbsct + return \U1f3f4[tag_from_ascii $code]\Ue007f + } + } + proc flag_to_ascii {charsequence} { + variable rflags + if {[dict exists $rflags $charsequence]} { + return [dict get $rflags $charsequence] + } + if {[string index $charsequence 0] eq "\U1F3F4" && [string index $charsequence end] eq "\UE007F"} { + #subdivision flag + set tag [string range $charsequence 1 end-1] + return [tag_to_ascii $tag] + } + error "unknown flag $charsequence" + } + proc tag_to_ascii {t} { + set fmt [string repeat %c [string length $t]] + set declist [scan $t $fmt] + #unicode Tags block - e0000 to e007f + set declist [lmap dec $declist { + if {$dec < 917504 || $dec > 917631} { + error "char [ansistring VIEW -lf 1 -cr 1 -vt 1 [format %c $dec]] has decimal value $dec. Not in unicode Tags block range 917504-917631 (e0000-e007f)" + } + incr dec -917504 + }] + return [format $fmt {*}$declist] + } + proc tag_from_ascii {a} { + set fmt [string repeat %c [string length $a]] + set declist [scan $a $fmt] + set declist [lmap dec $declist { + if {$dec > 127} { + error "char [ansistring VIEW -lf 1 -cr 1 -vt 1 [format %c $dec]] has decimal value $dec. Not in ascii range 0-127" + } + incr dec 917504 + }] + return [format $fmt {*}$declist] + } - #split into plaintext and runs of combiners (combining diacritical marks - not ZWJ or ZWJNJ) + #split into plaintext and runs of combiners (combining diacritical marks - not ZWJ or ZWJNJ) proc combiner_split {text} { #split into odd numbered list (or zero) in a similar way to punk::ansi::ta::_perlish_split # - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set graphemes [list] if {[tcl::string::length $text] == 0} { return {} @@ -2230,32 +2528,31 @@ tcl::namespace::eval punk::char { set list [list] set start 0 set strlen [tcl::string::length $text] - #make sure our regexes aren't non-greedy - or we may not have exit condition for loop + #make sure our regexes aren't non-greedy - or we may not have exit condition for loop #review while {$start < $strlen && [regexp -start $start -indices -- {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} $text match]} { lassign $match matchStart matchEnd #puts "->start $start ->match $matchStart $matchEnd" - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] - - #if {$start >= [tcl::string::length $text]} { - # break - #} } lappend list [tcl::string::range $text $start end] } #ZWJ ZWNJ ? + #SWSP ? #1st shot - basic diacritics #todo - become aware of unicode grapheme cluster boundaries #This is difficult in Tcl without unicode property based Character Classes in the regex engine #review - this needs to be performant - it is used a lot by punk terminal/ansi features #todo - trie data structures for unicode? - #for now we can at least combine diacritics + #for now we can at least combine diacritics #should also handle the ZWJ (and the variation selectors? eg \uFE0F) character which should account for emoji clusters #Note - emoji cluster could be for example 11 code points/41 bytes (family emoji with skin tone modifiers for each member, 3 ZWJs) #This still leaves a whole class of clusters.. korean etc unhandled :/ + #todo - tk::startOfCluster / tk::endOfCluster - try to get it brought into Tcl + #https://core.tcl-lang.org/tcl/tktview/a4c7eeaf63 proc grapheme_split {text} { set graphemes [list] set csplits [combiner_split $text] @@ -2263,7 +2560,7 @@ tcl::namespace::eval punk::char { set clist [split $pt ""] lappend graphemes {*}[lrange $clist 0 end-1] lappend graphemes [tcl::string::cat [lindex $clist end] $combiners] - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[split [lindex $csplits end] ""] @@ -2274,11 +2571,11 @@ tcl::namespace::eval punk::char { set graphemes [list] set csplits [combiner_split $text] foreach {pt combiners} [lrange $csplits 0 end-1] { - set pt_decs [scan $pt [tcl::string::repeat %c [tcl::string::length $pt]]] + set pt_decs [scan $pt [tcl::string::repeat %c [tcl::string::length $pt]]] ;#warning scan %c... slow for v large strings (e.g 400k+) set combiner_decs [scan $combiners [tcl::string::repeat %c [tcl::string::length $combiners]]] lset pt_decs end [concat [lindex $pt_decs end] $combiner_decs] lappend graphemes {*}$pt_decs - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[scan [lindex $csplits end] [tcl::string::repeat %c [tcl::string::length [lindex $csplits end]]]] @@ -2295,7 +2592,7 @@ tcl::namespace::eval punk::char { lset pt_decs end [concat [lindex $pt_decs end] $combiner_decs] } lappend graphemes {*}$pt_decs - } + } return $graphemes } proc grapheme_split2 {text} { @@ -2304,7 +2601,7 @@ tcl::namespace::eval punk::char { foreach {pt combiners} [lrange $csplits 0 end-1] { set clist [split $pt ""] lappend graphemes {*}[lrange $clist 0 end-1] [tcl::string::cat [lindex $clist end] $combiners] - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[split [lindex $csplits end] ""] @@ -2348,10 +2645,10 @@ tcl::namespace::eval punk::char { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::char [tcl::namespace::eval punk::char { 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/punk/config-0.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/config-0.1.tm new file mode 100644 index 00000000..ac70e97b --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -0,0 +1,487 @@ + +tcl::namespace::eval punk::config { + variable loaded + variable startup ;#include env overrides + variable running + variable punk_env_vars + variable other_env_vars + + variable vars + + namespace export {[a-z]*} + + #todo - XDG_DATA_HOME etc + #https://specifications.freedesktop.org/basedir-spec/latest/ + # see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ + + proc init {} { + variable defaults + variable startup + variable running + variable punk_env_vars + variable punk_env_vars_config + variable other_env_vars + variable other_env_vars_config + + set exename "" + catch { + #catch for safe interps + #safe base will return empty string, ordinary safe interp will raise error + set exename [tcl::info::nameofexecutable] + } + if {$exename ne ""} { + set exefolder [file dirname $exename] + #default file logs to logs folder at same level as exe if writable, or empty string + set log_folder [file normalize $exefolder/../logs] ;#~2ms + #tcl::dict::set startup scriptlib $exefolder/scriptlib + #tcl::dict::set startup apps $exefolder/../../punkapps + + #todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc + set default_scriptlib $exefolder/scriptlib + set default_apps $exefolder/../../punkapps + if {[file isdirectory $log_folder] && [file writable $log_folder]} { + #tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt + #tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt + set default_logfile_stdout $log_folder/repl-exec-stdout.txt + set default_logfile_stderr $log_folder/repl-exec-stderr.txt + } else { + set default_logfile_stdout "" + set default_logfile_stderr "" + } + } else { + #probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island + #review - todo? + #tcl::dict::set startup scriptlib "" + #tcl::dict::set startup apps "" + set default_scriptlib "" + set default_apps "" + set default_logfile_stdout "" + set default_logfile_stderr "" + } + + # auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run + + #optional channel transforms on stdout/stderr. + #can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands + #If no distinction necessary - should use default_color_ + #The counterpart: default_color__repl is a transform that is added and removed with each repl evaluation. + #startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default + set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) + set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only + #This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. + #set default_color_stderr "red bold" + #set default_color_stderr "web-lightsalmon" + set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive + set default_color_stderr_repl "" ;#during repl call only + + set homedir "" + if {[catch { + #depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp + #other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp + set homedir [file home] + } errM]} { + #tcl 8.6 doesn't have file home.. try again + if {[info exists ::env(HOME)]} { + set homedir $::env(HOME) + } + } + + + # per user xdg vars + # --- + set default_xdg_config_home "" ;#config data - portable + set default_xdg_data_home "" ;#data the user likely to want to be portable + set default_xdg_cache_home "" ;#local cache + set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home + # --- + set default_xdg_data_dirs "" ;#non-user specific + #xdg_config_dirs ? + #xdg_runtime_dir ? + + + #review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) + #(safe interp generally won't have access to ::env either) + #This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. + if {$homedir ne ""} { + if {"windows" eq $::tcl_platform(platform)} { + #as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. + #we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) + #using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. + if {[info exists ::env(APPDATA)]} { + set default_xdg_config_home $::env(APPDATA) + set default_xdg_data_home $::env(APPDATA) + } + + #The xdg_cache_home should be kept local + if {[info exists ::env(LOCALAPPDATA)]} { + set default_xdg_cache_home $::env(LOCALAPPDATA) + set default_xdg_state_home $::env(LOCALAPPDATA) + } + + if {[info exists ::env(PROGRAMDATA)]} { + #- equiv env(ALLUSERSPROFILE) ? + set default_xdg_data_dirs $::env(PROGRAMDATA) + } + + } else { + #follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html + set default_xdg_config_home [file join $homedir .config] + set default_xdg_data_home [file join $homedir .local share] + set default_xdg_cache_home [file join $homedir .cache] + set default_xdg_state_home [file join $homedir .local state] + set default_xdg_data_dirs /usr/local/share + } + } + + set defaults [dict create\ + apps $default_apps\ + config ""\ + configset ".punkshell"\ + scriptlib $default_scriptlib\ + color_stdout $default_color_stdout\ + color_stdout_repl $default_color_stdout_repl\ + color_stderr $default_color_stderr\ + color_stderr_repl $default_color_stderr_repl\ + logfile_stdout $default_logfile_stdout\ + logfile_stderr $default_logfile_stderr\ + logfile_active 0\ + syslog_stdout "127.0.0.1:514"\ + syslog_stderr "127.0.0.1:514"\ + syslog_active 0\ + auto_exec_mechanism exec\ + auto_noexec 0\ + xdg_config_home $default_xdg_config_home\ + xdg_data_home $default_xdg_data_home\ + xdg_cache_home $default_xdg_cache_home\ + xdg_state_home $default_xdg_state_home\ + xdg_data_dirs $default_xdg_data_dirs\ + theme_posh_override ""\ + posh_theme ""\ + posh_themes_path ""\ + ] + + set startup $defaults + #load values from saved config file - $xdg_config_home/punk/punk.config ? + #typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. + #that's possibly ok for the PUNK_ vars + #however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? + #making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? + #simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden + #- requiring user to manually unset any unwanted env vars when launching? + + #we are likely to want the saved configs for subshells/decks to override them however. + + #todo - load/save config file + + #todo - define which configvars are settable in env + #list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) + set punk_env_vars_config [dict create \ + PUNK_APPS {type pathlist}\ + PUNK_CONFIG {type string}\ + PUNK_CONFIGSET {type string}\ + PUNK_SCRIPTLIB {type string}\ + PUNK_AUTO_EXEC_MECHANISM {type string}\ + PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ + PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ + PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ + PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ + PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ + PUNK_LOGFILE_STDOUT {type string}\ + PUNK_LOGFILE_STDERR {type string}\ + PUNK_LOGFILE_ACTIVE {type string}\ + PUNK_SYSLOG_STDOUT {type string}\ + PUNK_SYSLOG_STDERR {type string}\ + PUNK_SYSLOG_ACTIVE {type string}\ + PUNK_THEME_POSH_OVERRIDE {type string}\ + ] + set punk_env_vars [dict keys $punk_env_vars_config] + + #override with env vars if set + foreach {evar varinfo} $punk_env_vars_config { + if {[info exists ::env($evar)]} { + set vartype [dict get $varinfo type] + set f [set ::env($evar)] + if {$f ne "default"} { + #e.g PUNK_SCRIPTLIB -> scriptlib + set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] + if {$vartype eq "pathlist"} { + #colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system + #Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. + #For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. + #some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. + #An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting + # - but some programs have been known to split this value on colon anyway, which breaks things on windows. + set paths [split $f $::tcl_platform(pathSeparator)] + set final [list] + #eliminate empty values (leading or trailing or extraneous separators) + foreach p $paths { + if {[tcl::string::trim $p] ne ""} { + lappend final $p + } + } + tcl::dict::set startup $varname $final + } else { + tcl::dict::set startup $varname $f + } + } + } + } + + # https://no-color.org + #if {[info exists ::env(NO_COLOR)]} { + # if {$::env(NO_COLOR) ne ""} { + # set colour_disabled 1 + # } + #} + set other_env_vars_config [dict create\ + NO_COLOR {type string}\ + XDG_CONFIG_HOME {type string}\ + XDG_DATA_HOME {type string}\ + XDG_CACHE_HOME {type string}\ + XDG_STATE_HOME {type string}\ + XDG_DATA_DIRS {type pathlist}\ + POSH_THEME {type string}\ + POSH_THEMES_PATH {type string}\ + TCLLIBPATH {type string}\ + ] + lassign [split [info tclversion] .] tclmajorv tclminorv + #don't rely on lseq or punk::lib for now.. + set relevant_minors [list] + for {set i 0} {$i <= $tclminorv} {incr i} { + lappend relevant_minors $i + } + foreach minor $relevant_minors { + set vname TCL${tclmajorv}_${minor}_TM_PATH + if {$minor eq $tclminorv || [info exists ::env($vname)]} { + dict set other_env_vars_config $vname {type string} + } + } + set other_env_vars [dict keys $other_env_vars_config] + + foreach {evar varinfo} $other_env_vars_config { + if {[info exists ::env($evar)]} { + set vartype [dict get $varinfo type] + set f [set ::env($evar)] + if {$f ne "default"} { + set varname [tcl::string::tolower $evar] + if {$vartype eq "pathlist"} { + set paths [split $f $::tcl_platform(pathSeparator)] + set final [list] + #eliminate empty values (leading or trailing or extraneous separators) + foreach p $paths { + if {[tcl::string::trim $p] ne ""} { + lappend final $p + } + } + tcl::dict::set startup $varname $final + } else { + tcl::dict::set startup $varname $f + } + } + } + } + + + #unset -nocomplain vars + + #todo + set running [tcl::dict::create] + set running [tcl::dict::merge $running $startup] + } + init + + #todo + proc Apply {config} { + puts stderr "punk::config::Apply partially implemented" + set configname [string map {-config ""} $config] + if {$configname in {startup running}} { + upvar ::punk::config::$configname applyconfig + + if {[dict exists $applyconfig auto_noexec]} { + set auto [dict get $applyconfig auto_noexec] + if {![string is boolean -strict $auto]} { + error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" + } + if {$auto} { + set ::auto_noexec 1 + } else { + #puts "auto_noexec false" + unset -nocomplain ::auto_noexec + } + } + + } else { + error "no config named '$config' found" + } + return "apply done" + } + Apply startup + + #todo - consider how to divide up settings, categories, 'devices', decks etc + proc get_running_global {varname} { + variable running + if {[dict exists $running $varname]} { + return [dict get $running $varname] + } + error "No such global configuration item '$varname' found in running config" + } + proc get_startup_global {varname} { + variable startup + if {[dict exists $startup $varname]} { + return [dict get $startup $varname] + } + error "No such global configuration item '$varname' found in startup config" + } + + proc get {whichconfig {globfor *}} { + variable startup + variable running + switch -- $whichconfig { + config - startup - startup-config - startup-configuration { + #show *startup* config - different behaviour may be confusing to those used to router startup and running configs + set configdata $startup + } + running - running-config - running-configuration { + set configdata $running + } + default { + error "Unknown config name '$whichconfig' - try startup or running" + } + } + if {$globfor eq "*"} { + return $configdata + } else { + set keys [dict keys $configdata [string tolower $globfor]] + set filtered [dict create] + foreach k $keys { + dict set filtered $k [dict get $configdata $k] + } + return $filtered + } + } + + proc configure {args} { + set argdef { + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ + "UNIMPLEMENTED" + @values -min 1 -max 1 + whichconfig -type string -choices {startup running stop} + } + set argd [punk::args::get_dict $argdef $args] + return "unimplemented - $argd" + } + + proc show {whichconfig {globfor *}} { + #todo - tables for console + set configdata [punk::config::get $whichconfig $globfor] + return [punk::lib::showdict $configdata] + } + + + + #e.g + # copy running-config startup-config + # copy startup-config test-config.cfg + # copy backup-config.cfg running-config + #review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite + #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration + proc copy {args} { + set argdef { + @id -id ::punk::config::copy + @cmd -name punk::config::copy -help\ + "Copy a partial or full configuration from one config to another + If a target config has additional settings, then the source config can be considered to be partial with regards to the target. + " + -type -default "" -choices {replace merge} -help\ + "Defaults to merge when target is running-config + Defaults to replace when source is running-config" + @values -min 2 -max 2 + fromconfig -help\ + "running or startup or file name (not fully implemented)" + toconfig -help\ + "running or startup or file name (not fully implemented)" + } + set argd [punk::args::get_dict $argdef $args] + set fromconfig [dict get $argd values fromconfig] + set toconfig [dict get $argd values toconfig] + set fromconfig [string map {-config ""} $fromconfig] + set toconfig [string map {-config ""} $toconfig] + + set copytype [dict get $argd opts -type] + + + #todo - warn & prompt if doing merge copy to startup + switch -exact -- $fromconfig-$toconfig { + running-startup { + if {$copytype eq ""} { + set copytype replace ;#full configuration + } + if {$copytype eq "replace"} { + error "punk::config::copy error. full configuration copy from running to startup config not yet supported" + } else { + error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" + } + } + startup-running { + #default type merge - even though it's not always what is desired + if {$copytype eq ""} { + set copytype merge ;#load in a partial configuration + } + + #warn/prompt either way + if {$copytype eq "replace"} { + #some routers require use of a separate command for this branch. + #presumably to ensure the user doesn't accidentally load partials onto a running system + # + error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" + } else { + error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" + } + } + default { + error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" + } + } + } + + + + + +} + + + + + +#todo - move to cli? +::tcl::namespace::eval punk::config { + #todo - something better - 'previous' rather than reverting to startup + proc channelcolors {{onoff {}}} { + variable running + variable startup + + if {![string length $onoff]} { + return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + } else { + if {![string is boolean $onoff]} { + error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" + } + if {$onoff} { + dict set running color_stdout [dict get $startup color_stdout] + dict set running color_stderr [dict get $startup color_stderr] + } else { + dict set running color_stdout "" + dict set running color_stderr "" + } + } + return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + } +} + +package provide punk::config [tcl::namespace::eval punk::config { + variable version + set version 0.1 + +}] \ No newline at end of file diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index 3c64c7e3..a3f5d95c 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -13,11 +13,55 @@ # @@ Meta End +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::console 0 0.1.1] +#[copyright "2024"] +#[titledesc {punk console}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk console}] [comment {-- Description at end of page heading --}] +#[require punk::console] +#[keywords module console terminal] +#[description] +#[para] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::console +#[subsection Concepts] +#[para] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements -##e.g package require frobz +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::console +#[list_begin itemized] + +package require Tcl 8.6- +package require Thread ;#tsv required to sync is_raw package require punk::ansi +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {Thread}] +#[item] [package {punk::ansi}] +#[item] [package {punk::args}] + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + #if {"windows" eq $::tcl_platform(platform)} { @@ -30,6 +74,15 @@ package require punk::ansi # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::console { + #*** !doctools + #[subsection {Namespace punk::console}] + #[para] + + #*** !doctools + #[list_begin definitions] + + variable PUNKARGS + variable tabwidth 8 ;#default only - will attempt to detect and set to that configured in terminal #Note that windows terminal cooked mode seems to use 8 for interactive use even if set differently #e.g typing tab characters may still be echoed 8-spaced while writing to stdout my obey the terminal's tab stops. @@ -37,14 +90,20 @@ namespace eval punk::console { variable previous_stty_state_stdin "" variable previous_stty_state_stdout "" variable previous_stty_state_stderr "" - variable is_raw 0 + + #variable is_raw 0 + if {![tsv::exists console is_raw]} { + tsv::set console is_raw 0 + } + variable input_chunks_waiting if {![info exists input_chunks_waiting(stdin)]} { set input_chunks_waiting(stdin) [list] } variable ansi_response_chunk ;#array keyed on callid variable ansi_response_wait ;#array keyed on callid - variable ansi_response_queue ;#list of callids + array set ansi_response_wait {} + variable ansi_response_queue [list];#list of callids variable ansi_response_queuedata ;#dict keyed on callid - with function params # -- @@ -56,6 +115,8 @@ namespace eval punk::console { variable ansi_wanted 2 ;#2 for default assumed yes, will be set to -1 for automatically unwanted when ansi unavailable values of 0 or 1 won't be autoset + + #punk::console namespace - contains *directly* acting functions - some based on ansi escapes from the 'ansi' sub namespace, some on local system calls or executable calls wrapped in the 'local' sub namespace #directly acting means they write to stdout to cause the console to peform the action, or they perform the action immediately via other means. #punk::console::ansi contains a subset of punk::ansi, but with emission to stdout as opposed to simply returning the ansi sequence. @@ -63,10 +124,6 @@ namespace eval punk::console { #ansi escape sequences are possibly preferable esp if terminal is remote to process running punk::console # punk::local commands may be more performant in some circumstances where console is directly attached, but it shouldn't be assumed. e.g ansi::titleset outperforms local::titleset on windows with twapi. - namespace eval ansi { - #ansi escape sequence based terminal/console control functions - namespace export * - } namespace eval local { #non-ansi terminal/console control functions #e.g external utils system API's. @@ -130,31 +187,38 @@ namespace eval punk::console { } - #todo - something better - the 'channel' concept may not really apply on unix, as raw mode is for input and output modes + #todo - something better - the 'channel' concept may not really apply on unix, as raw mode is set for input and output modes currently - only valid to set on a readable channel? + #on windows they can be set independently (but not with stty) - REVIEW + + #NOTE - the is_raw is only being set in current interp - but the channel is shared. + #this is problematic with the repl thread being separate. - must be a tsv? REVIEW proc enableRaw {{channel stdin}} { - variable is_raw + #variable is_raw + variable previous_stty_state_$channel set sttycmd [auto_execok stty] if {[set previous_stty_state_$channel] eq ""} { - set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] + if {[catch {exec {*}$sttycmd -g <@$channel} previous_stty_state_$channel]} { + set previous_stty_state_$channel "" + } } exec {*}$sttycmd raw -echo <@$channel - set is_raw 1 + tsv::set console is_raw 1 return [dict create previous [set previous_stty_state_$channel]] } proc disableRaw {{channel stdin}} { - variable is_raw + #variable is_raw variable previous_stty_state_$channel set sttycmd [auto_execok stty] if {[set previous_stty_state_$channel] ne ""} { exec {*}$sttycmd [set previous_stty_state_$channel] set previous_stty_state_$channel "" - set is_raw 0 + tsv::set console is_raw 0 return restored } exec {*}$sttycmd -raw echo <@$channel - set is_raw 0 + tsv::set console is_raw 0 return done } proc enableVirtualTerminal {{channels {input output}}} { @@ -195,24 +259,34 @@ namespace eval punk::console { enable_bracketed_paste } + #todo stop_application_mode {} {} + proc mode {{raw_or_line query}} { - variable is_raw + #variable is_raw variable ansi_available set raw_or_line [string tolower $raw_or_line] if {$raw_or_line eq "query"} { - if {$is_raw} { + if {[tsv::get console is_raw]} { return "raw" } else { return "line" } } elseif {$raw_or_line eq "raw"} { - punk::console::enableRaw + if {[catch { + punk::console::enableRaw + } errM]} { + puts stderr "Warning punk::console::enableRaw failed - $errM" + } if {[can_ansi]} { punk::console::enableVirtualTerminal both } } elseif {$raw_or_line eq "line"} { #review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) - punk::console::disableRaw + if {[catch { + punk::console::disableRaw + } errM]} { + puts stderr "Warning punk::console::disableRaw failed - $errM" + } if {[can_ansi]} { punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc punk::console::enableVirtualTerminal output ;#display/use ansi codes @@ -243,12 +317,15 @@ namespace eval punk::console { set loadstate [zzzload::pkg_require twapi] #loadstate could also be stuck on loading? - review - zzzload not very ripe - #Twapi is relatively slow to load - can be 1s plus in normal cases - and much longer if there are disk performance issues. - + #Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues. if {$loadstate ni [list failed]} { + #possibly still 'loading' #review zzzload usage #puts stdout "=========== console loading twapi =============" - zzzload::pkg_wait twapi + set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait + } + + if {$loadstate ni [list failed]} { package require twapi ;#should be fast once twapi dll loaded in zzzload thread set ::punk::console::has_twapi 1 @@ -429,7 +506,7 @@ namespace eval punk::console { } proc [namespace parent]::enableRaw {{channel stdin}} { - variable is_raw + #variable is_raw variable previous_stty_state_$channel if {[package provide twapi] ne ""} { @@ -442,7 +519,7 @@ namespace eval punk::console { #set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]] set newmode [twapi::get_console_input_mode] - set is_raw 1 + tsv::set console is_raw 1 #don't disable handler - it will detect is_raw ### twapi::set_console_control_handler {} return [list stdin [list from $oldmode to $newmode]] @@ -452,7 +529,7 @@ namespace eval punk::console { } exec {*}$sttycmd raw -echo <@$channel - set is_raw 1 + tsv::set console is_raw 1 #review - inconsistent return dict return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] } else { @@ -464,7 +541,7 @@ namespace eval punk::console { #could be we were missing a step in reopening stdin and console configuration? proc [namespace parent]::disableRaw {{channel stdin}} { - variable is_raw + #variable is_raw variable previous_stty_state_$channel if {[package provide twapi] ne ""} { @@ -473,9 +550,12 @@ namespace eval punk::console { # Turn on the echo and line-editing bits twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1 set newmode [twapi::get_console_input_mode] - set is_raw 0 + tsv::set console is_raw 0 return [list stdin [list from $oldmode to $newmode]] } elseif {[set sttycmd [auto_execok stty]] ne ""} { + #stty can return info on windows - but doesn't seem to be able to set anything. + #review - is returned info even valid? + set sttycmd [auto_execok stty] if {[set previous_stty_state_$channel] ne ""} { exec {*}$sttycmd [set previous_stty_state_$channel] @@ -483,7 +563,7 @@ namespace eval punk::console { return restored } exec {*}$sttycmd -raw echo <@$channel - set is_raw 0 + tsv::set console is_raw 0 #do we really want to exec stty yet again to show final 'to' state? #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] @@ -495,12 +575,73 @@ namespace eval punk::console { } - #capturingendregex should capture ANY prefix, whole escape match - and a subcapture of the data we're interested in and match at end of string. - #ie {(.*)(ESC(info)end)$} - #e.g {(.*)(\x1bP44!~([:alnum:])\x1b\\)$} - #we expect 4 results from regexp -indices -inline (overallmatch, prefix, wholeescape,info) + lappend PUNKARGS [list { + @id -id ::punk::console::internal::get_ansi_response_payload + @cmd -name punk::console::internal::get_ansi_response_payload -help\ + "Terminal query helper. + Captures the significant portion (payload as defined by + supplied capturingendregex capture groups) of the input + channel's response to a query placed on the output channel. + Usually this means a write to stdout with a response on + stdin. + This function uses a 'chan event' read handler function + ::punk::console::internal::ansi_response_handler_regex to + read the input channel character by character to ensure it + doesn't overconsume input. + + It can run cooperatively with the punk::repl stdin reader + or other readers if done carefully. + The mechanism to run while other readers are active involves + disabling and re-enabling installed 'chan event' handlers + and possibly using a shared namespace variable + (::punk::console::input_chunks_waiting) to ensure all data + gets to the right handler. (unread data on input prior to this + function being called) + Not fully documented. (source diving required -see punk::repl) + " + @opts + -ignoreok -type boolean -default 0 -help\ + "Experimental/debug + ignore the regex match 'ok' response + and keep going." + -return -type string -default payload -choices {payload dict} -choicelabels { + dict\ + "dict with keys prefix,response,payload,all" + } -help\ + "Return format" + + -terminal -default {stdin stdout} -type list -help\ + "terminal (currently list of in/out channels) (todo - object?)" + -expected_ms -default 100 -type integer -help\ + "Expected number of ms for response from terminal. + 100ms is usually plenty for a local terminal and a + basic query such as cursor position." + @values -min 2 -max 2 + query -type string -help\ + "ANSI sequence such as \x1b\[?6n which + should elicit a response by the terminal + on stdin" + capturingendregex -type string -help\ + "capturingendregex should capture ANY prefix, whole escape match - and a subcapture + of the data we're interested in; and match at end of string. + ie {(.*)(ESC(info)end)$} + e.g {(.*)(\x1bP44!~([:alnum:])\x1b\\)$} + we expect 4 results from regexp -indices -inline (overallmatch, prefix, wholeescape,info)" + }] #todo - check capturingendregex value supplied has appropriate captures and tail-anchor - proc get_ansi_response_payload {query capturingendregex {inoutchannels {stdin stdout}}} { + proc get_ansi_response_payload {args} { + #we pay a few 10s of microseconds to use punk::args::parse (on the happy path) + #seems reasonable for the flexibility in this case. + set argd [punk::args::parse $args withid ::punk::console::internal::get_ansi_response_payload] + lassign [dict values $argd] leaders opts values received + + set inoutchannels [dict get $opts -terminal] + set expected [dict get $opts -expected_ms] + set ignoreok [dict get $opts -ignoreok] + set returntype [dict get $opts -return] + set query [dict get $values query] + set capturingendregex [dict get $values capturingendregex] + lassign $inoutchannels input output #chunks from input that need to be handled by readers @@ -512,31 +653,55 @@ namespace eval punk::console { #In other contexts there may not even be another input reader #REVIEW - what if there is existing data in input_chunks_waiting - is it for us? - #temp - let's keep alert to it until we decide if it's legit/required.. - if {[info exists input_chunks_waiting($input)] && [llength $input_chunks_waiting($input)]} { - #puts stderr "[punk::ansi::a+ cyan bold]get_ansi_response_payload called while input_chunks_waiting($input) contained data: $input_chunks_waiting($input)[punk::ansi::a]" - } + #This occurs for example with key held down on autorepeat and is normal + #enable it here for debug/testing only + #if {[info exists input_chunks_waiting($input)] && [llength $input_chunks_waiting($input)]} { + # puts stderr "[punk::ansi::a+ cyan bold]get_ansi_response_payload called while input_chunks_waiting($input) contained data: [punk::ansi::a][ansistring VIEW $input_chunks_waiting($input)]" + #} + if {!$::punk::console::ansi_available} { return "" } - set callid [info cmdcount] ;#info cmdcount is almost as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context + # -- --- + #set callid [info cmdcount] ;#info cmdcount is fast, though not as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context + #clock clicks is approx 2x faster - but can sometimes give duplicates if called sequentially e.g list [clock clicks] [clock clicks] + #Either is suitable here, where subsequent calls will be relatively far apart in time + #speed of call insignificant compared to function + set callid [clock clicks] + # -- --- # upvar ::punk::console::ansi_response_chunk accumulator upvar ::punk::console::ansi_response_wait waitvar upvar ::punk::console::ansi_response_queue queue upvar ::punk::console::ansi_response_queuedata queuedata - upvar ::punk::console::ansi_response_clock clock + upvar ::punk::console::ansi_response_tslaunch tslaunch + upvar ::punk::console::ansi_response_tsclock tsclock upvar ::punk::console::ansi_response_timeoutid timeoutid - set accumulator($callid) "" - set waitvar($callid) "" - lappend queue $callid + set accumulator($callid) "" + set waitvar($callid) "" + + lappend queue $callid + if {[llength $queue] > 1} { + #while {[lindex $queue 0] ne $callid} {} + set queuedata($callid) $args + set runningid [lindex $queue 0] + while {$runningid ne $callid} { + vwait ::punk::console::ansi_response_wait + set runningid [lindex $queue 0] + if {$runningid ne $callid} { + set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid) + update ;#REVIEW - probably a bad idea + after 10 + } + } + } #todo - use a linked array and an accumulatorid and waitvar id? When can there be more than one terminal query in-flight? - set existing_handler [fileevent $input readable] ;#review! + set existing_handler [chan event $input readable] ;#review! set this_handler ::punk::console::internal::ansi_response_handler_regex if {[lindex $existing_handler 0] eq $this_handler} { puts stderr "[punk::ansi::a+ red]Warning for callid $callid get_ansi_response_payload called while existing ansi response handler in place[a]: $this_handler" @@ -544,109 +709,154 @@ namespace eval punk::console { flush stderr if {[lindex $queue 0] ne $callid} { + error "get_ansi_response_payload - re-entrancy unrecoverable" } - error "get_ansi_response_payload - re-entrancy unrecoverable" } + chan event $input readable {} - fileevent $input readable {} - - set input_state [fconfigure $input] - #todo - make timeout configurable? - set waitvarname "::punk::console::ansi_response_wait($callid)" - #500ms is generally plenty for a terminal to respond.. but not in some cases. e.g event loop busy with stdin keypress?? review - set timeoutid($callid) [after 2000 [list set $waitvarname timedout]] - - #JMN # - stderr vs stdout #It has to be same channel as used by functions such as test_char_width or erroneous results returned for those functions #(presumably race conditions as to when data hits console?) #review - experiment changing this and calling functions to stderr and see if it works #review - Are there disadvantages to using stdout vs stderr? - #puts stdout "sending console request [ansistring VIEW $query]" - puts -nonewline $output $query;flush $output + + set previous_input_state [chan configure $input] + #chan configure $input -blocking 0 + + #todo - make timeout configurable? + set waitvarname "::punk::console::ansi_response_wait($callid)" + #todo - test and save rawstate so we don't disableRaw if console was already raw - if {!$::punk::console::is_raw} { + if {![tsv::get console is_raw]} { set was_raw 0 punk::console::enableRaw + #after 0 [list chan event $input readable [list $this_handler $input $callid $capturingendregex]] + incr expected 50 ;#review + set timeoutid($callid) [after $expected [list set $waitvarname timedout]] + #puts stdout "sending console request [ansistring VIEW $query]" } else { set was_raw 1 + set timeoutid($callid) [after $expected [list set $waitvarname timedout]] } - fconfigure $input -blocking 0 - # - #in handler - its used for a boolean match (capturing aspect not used) - set clock($callid) [clock millis] ;#time of launch - may be delay before first event depending on what's going on - - #first shot without using filevent, call the stdin reader directly - maybe it's there already - #This can be significantly faster than setting up a fileevent (2024 e.g 1.5ms vs 65ms) + #write before console enableRaw vs after?? + #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it + puts -nonewline $output $query;flush $output + chan configure $input -blocking 0 + + set tslaunch($callid) [clock millis] ;#time of launch - may be delay before first event depending on what's going on + set tsclock($callid) $tslaunch($callid) + #after 0 + #------------------ + #trying alternatives to get faster read and maintain reliability..REVIEW + #we should care more about performance in raw mode - as ultimately that's the one we prefer for full features + #------------------ + # 1) faster - races? $this_handler $input $callid $capturingendregex - if {$waitvar($callid) ne "ok"} { - fileevent $input readable [list $this_handler $input $callid $capturingendregex] + $this_handler $input $callid $capturingendregex + if {$ignoreok || $waitvar($callid) ne "ok"} { + chan event $input readable [list $this_handler $input $callid $capturingendregex] } + # 2) more reliable? + #chan event $input readable [list $this_handler $input $callid $capturingendregex] + #------------------ - #JMN #response from terminal #e.g for cursor position \033\[46;1R - - if {[set waitvar($callid)] eq ""} { - vwait ::punk::console::ansi_response_wait($callid) + #after 0 [list $this_handler $input $callid $capturingendregex] + set remaining $expected + if {$waitvar($callid) eq ""} { + set lastvwait [clock millis] + vwait ::punk::console::ansi_response_wait($callid) #puts stderr ">>>> end vwait1 $waitvar($callid)<<<<" - while {[string match extend-* $waitvar($callid)]} { - set extension [lindex [split $waitvar($callid) -] 1] - #puts stderr "get_ansi_response_payload Extending timeout by $extension" - #after cancel $timeoutid($callid) - set timeoutid($callid) [after $extension [list set $waitvarname timedout]] - vwait ::punk::console::ansi_response_wait($callid) + while {[string match extend-* $waitvar($callid)] || ($ignoreok && $waitvar($callid) eq "ok")} { + if {[string match extend-* $waitvar($callid)]} { + set extension [lindex [split $waitvar($callid) -] 1] + if {$extension eq ""} { + puts "blank extension $waitvar($callid)" + puts "->[set $waitvar($callid)]<-" + } + puts stderr "get_ansi_response_payload Extending timeout by $extension" + after cancel $timeoutid($callid) + set total_elapsed [expr {[clock millis] - $tslaunch($callid)}] + set last_elapsed [expr {[clock millis] - $lastvwait}] + set remaining [expr {$remaining - $last_elapsed}] + if {$remaining < 0} {set remaining 0} + set newtime [expr {$remaining + $extension}] + set timeoutid($callid) [after $newtime [list set $waitvarname timedout]] + set lastvwait [clock millis] + vwait ::punk::console::ansi_response_wait($callid) + } else { + #ignoreok - reapply the handler that disabled itself due to 'ok' + chan event $input readable [list $this_handler $input $callid $capturingendregex] + set lastvwait [clock millis] + vwait ::punk::console::ansi_response_wait($callid) + } } } - #response handler automatically removes it's own fileevent - fileevent $input readable {} ;#explicit remove anyway - review + #response handler automatically removes it's own chan event + chan event $input readable {} ;#explicit remove anyway - review if {$waitvar($callid) ne "timedout"} { after cancel $timeoutid($callid) } else { - puts stderr "timeout in get_ansi_response_payload. callid $callid Ansi request was:[ansistring VIEW -lf 1 -vt 1 $query]" + puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) in get_ansi_response_payload. callid $callid Ansi request was:'[ansistring VIEW -lf 1 -vt 1 $query]'" } if {$was_raw == 0} { punk::console::disableRaw } + #restore $input state - fconfigure $input -blocking [dict get $input_state -blocking] + #it *might* be ok to restore entire state on an input channel + #(it's not always on all channels - e.g stdout has -winsize which is read-only) + #Safest to only restore what we think we've modified. + chan configure $input -blocking [dict get $previous_input_state -blocking] - set response [set accumulator($callid)] + set input_read [set accumulator($callid)] - if {$response ne ""} { - set got_match [regexp -indices $capturingendregex $response _match_indices prefix_indices response_indices payload_indices] + if {$input_read ne ""} { + set got_match [regexp -indices $capturingendregex $input_read _match_indices prefix_indices response_indices payload_indices] if {$got_match} { - set responsedata [string range $response {*}$response_indices] - set payload [string range $response {*}$payload_indices] - set prefixdata [string range $response {*}$prefix_indices] - if {$prefixdata ne ""} { - #puts stderr "Warning - get_ansi_response_payload read extra data at start - '[ansistring VIEW -lf 1 $prefixdata]' (response=[ansistring VIEW -lf 1 $responsedata])" - lappend input_chunks_waiting($input) $prefixdata + set responsedata [string range $input_read {*}$response_indices] + set payload [string range $input_read {*}$payload_indices] + set prefixdata [string range $input_read {*}$prefix_indices] + if {!$ignoreok && $prefixdata ne ""} { + #puts stderr "Warning - get_ansi_response_payload read extra data at start - '[ansistring VIEW -lf 1 $prefixdata]' (responsedata=[ansistring VIEW -lf 1 $responsedata])" + lappend input_chunks_waiting($input) $prefixdata + } + } else { + #timedout - or eof? + if {!$ignoreok} { + puts stderr "get_ansi_response_payload callid:$callid regex match '$capturingendregex' to input_read '[ansistring VIEW -lf 1 -vt 1 $input_read]' not found" + lappend input_chunks_waiting($input) $input_read + set payload "" + } else { + set responsedata "" + set payload "" + set prefixdata "" } - } else { - #timedout - or eof? - puts stderr "get_ansi_response_payload callid:$callid regex match '$capturingendregex' to data '[ansistring VIEW -lf 1 -vt 1 $response]' not found" - lappend input_chunks_waiting($input) $response - set payload "" } } else { #timedout or eof? and nothing read - set payload "" + set responsedata "" + set prefixdata "" + set payload "" } + # ------------------------------------------------------------------------------------- + # Other input readers + # ------------------------------------------------------------------------------------- #is there a way to know if existing_handler is input_chunks_waiting aware? if {[string length $existing_handler] && [lindex $existing_handler 0] ne $this_handler} { #puts "get_ansi_response_payload reinstalling ------>$existing_handler<------" - fileevent $input readable $existing_handler - #we may have consumed all pending input on $input - so there may be no trigger for the readable fileevent + chan event $input readable $existing_handler + #this_handler may have consumed all pending input on $input - so there may be no trigger for the readable chan event for existing_handler if {[llength $input_chunks_waiting($input)]} { #This is experimental If a handler is aware of input_chunks_waiting - there should be no need to schedule a trigger #If it isn't, but the handler can accept an existing chunk of data as a 'waiting' argument - we could trigger and pass it the waiting chunks - but there's no way to know its API. @@ -662,11 +872,11 @@ namespace eval punk::console { flush stdout #concat and supply to existing handler in single text block - review - #Note will only + #Note will only set waitingdata [join $input_chunks_waiting($input) ""] set input_chunks_waiting($input) [list] #after idle [list after 0 [list {*}$existing_handler $waitingdata]] - after idle [list {*}$existing_handler $waitingdata] ;#after 0 may be put ahead of events it shouldn't be - review + after idle [list {*}$existing_handler $waitingdata] ;#after 0 may be put ahead of events it shouldn't be - review unset waitingdata } else { #! todo? for now, emit a clue as to what's happening. @@ -683,83 +893,123 @@ namespace eval punk::console { #The input_chunks_waiting may really belong to the existing_handler we found - but if it doesn't consume them they will end up being read by the repl_handler when it eventually re-enables. #todo - some better structure than just a list of waiting chunks indexed by input channel, so repl/other handlers can determine the context in which these waiting chunks were generated? } elseif {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { - if {[llength $input_chunks_waiting($input)]} { + #if {[llength $input_chunks_waiting($input)]} { #don't trigger the repl handler manually - we will inevitably get things out of order - as it knows when to enable/disable itself based on whether chunks are waiting. #triggering it by putting it on the eventloop will potentially result in re-entrancy #The cooperating reader must be designed to consume waiting chunks and only reschedule it's channel read handler once all waiting chunks have been consumed. #puts stderr "[punk::ansi::a+ green bold]--> repl_handler has chunks to consume [ansistring VIEW $input_chunks_waiting($input)][punk::ansi::a]" - } + #} if {[eof $input]} { #test - puts stdout "restarting repl" + puts stdout "get_ansi_response_payload experimental - restarting repl" repl::reopen stdin } } + # ------------------------------------------------------------------------------------- - catch { - unset accumulator($callid) - unset waitvar($callid) - dict unset queuedata $callid - } - if {[llength $queue] > 1} { - set next_callid [lindex $queue 1] + + + unset -nocomplain accumulator($callid) + unset -nocomplain waitvar($callid) + unset -nocomplain timeoutid($callid) + unset -nocomplain tsclock($callid) + unset -nocomplain tslaunch($callid) + dict unset queuedata $callid + + lpop queue 0 + if {[llength $queue] > 0} { + set next_callid [lindex $queue 0] set waitvar($callid) go_ahead + #set nextdata [set queuedata($next_callid)] } - lpop queue 0 + #set punk::console::chunk "" - return $payload + if {$returntype eq "dict"} { + return [dict create\ + prefix $prefixdata\ + payload $payload\ + response $responsedata\ + all $input_read\ + ] + } else { + return $payload + } } #review - reading 1 byte at a time and repeatedly running the small capturing/completion regex seems a little inefficient... but we don't have a way to peek or put back chars (?) #review (we do have the punk::console::input_chunks_waiting($chan) array to cooperatively put back data - but this won't work for user scripts not aware of this) #review - timeout - what if terminal doesn't put data on stdin? error vs stderr report vs empty results - #review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? + #review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? #e.g what happens to mouse-events while user code is executing? #we may still need this handler if such a loop doesn't exist. proc ansi_response_handler_regex {chan callid endregex} { upvar ::punk::console::ansi_response_chunk chunks upvar ::punk::console::ansi_response_wait waits - upvar ::punk::console::ansi_response_clock clock ;#initial time in millis was set when fileevent was created + upvar ::punk::console::ansi_response_tslaunch tslaunch ;#initial time in millis was set when chan event was created + upvar ::punk::console::ansi_response_tsclock tsclock #endregex should explicitly have a trailing $ set status [catch {read $chan 1} bytes] if { $status != 0 } { # Error on the channel - fileevent $chan readable {} + chan event $chan readable {} puts "ansi_response_handler_regex error reading $chan: $bytes" - set waits($callid) [list error_read status $status bytes $bytes] + set waits($callid) [list error error_read status $status bytes $bytes] } elseif {$bytes ne ""} { + #puts stderr . ;flush stderr # Successfully read the channel #puts "got: [string length $bytes]bytes" - append chunks($callid) $bytes + set sofar [append chunks($callid) $bytes] #puts stderr [ansistring VIEW $chunks($callid)] - if {[regexp $endregex $chunks($callid)]} { - fileevent $chan readable {} + #review - what is min length of any ansiresponse? + #we know there is at least one of only 3 chars, vt52 response to ESC Z: ESC / Z + #endregex is capturing - but as we are only testing the match here + #it should perform the same as if it were non-capturing + if {[string length $sofar] > 2 && [regexp $endregex $sofar]} { #puts stderr "matched - setting ansi_response_wait($callid) ok" + chan event $chan readable {} set waits($callid) ok } else { - if {[string length $chunks($callid)] % 10 == 0 || $clock($callid) - [clock millis] > 50} { - after cancel $::punk::console::ansi_response_timeoutid($callid) - set waits($callid) extend-1000 + # 30ms 16ms? + set tsnow [clock millis] + set total_elapsed [expr {[set tslaunch($callid)] - $tsnow}] + set last_elapsed [expr {[set tsclock($callid)] - $tsnow}] + if {[string length $chunks($callid)] % 10 == 0 || $last_elapsed > 16} { + if {$total_elapsed > 3000} { + #REVIEW + #too long since initial read handler launched.. + #is other data being pumped into stdin? Eventloop starvation? Did we miss our codes? + #For now we'll stop extending the timeout. + after cancel $::punk::console::ansi_response_timeoutid($callid) + set waits($callid) [list error error_ansi_response_handler_regex_too_long_reading] + } else { + if {$last_elapsed > 0} { + after cancel $::punk::console::ansi_response_timeoutid($callid) + set waits($callid) extend-[expr {min(16,$last_elapsed)}] + } + } } + set tsclock(callid) [clock millis] } } elseif {[catch {eof $chan}] || [eof $chan]} { - catch {fileevent $chan readable {}} + catch {chan event $chan readable {}} # End of file on the channel #review puts stderr "ansi_response_handler_regex end of file on channel $chan" set waits($callid) eof - } elseif {![catch {fblocked $chan}] && [fblocked $chan]} { - # Read blocked. Just return + } elseif {![catch {chan blocked $chan}] && [chan blocked $chan]} { + # Read blocked is normal. (chan -blocking = 0 but reading only 1 char) # Caller should be using timeout on the wait variable + #set waits($callid) continue + set tsclock($callid) [clock millis] } else { - fileevent $chan readable {} + chan event $chan readable {} # Something else - puts stderr "ansi_response_handler_regex Situation shouldn't be possible. No error and no bytes read on channel $chan but chan is not fblocked or EOF" - set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof + puts stderr "ansi_response_handler_regex Situation shouldn't be possible. No error and no bytes read on channel $chan but not chan blocked or EOF" + set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof } } } ;#end namespace eval internal @@ -776,25 +1026,19 @@ namespace eval punk::console { #a and a+ functions are not very useful when emitting directly to console #e.g puts [punk::console::a red]test[punk::console::a cyan] would produce a cyan coloured test as the commands are evaluated first - proc a? {args} { - #stdout - variable ansi_wanted - if {$ansi_wanted <= 0} { - puts -nonewline [punk::ansi::ansistripraw [::punk::ansi::a?]] - } else { - tailcall ansi::a? {*}$args - } - } + #punk::args::set_alias ::punk::console::code_a+ ::punk::ansi::a+ + lappend PUNKARGS_aliases {::punk::console::code_a+ ::punk::ansi::a+} proc code_a+ {args} { variable ansi_wanted if {$ansi_wanted <= 0} { return } - #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here + #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here #tailcall punk::ansi::a+ {*}$args ::punk::ansi::a+ {*}$args } + lappend PUNKARGS_aliases {::punk::console::code_a ::punk::ansi::a} proc code_a {args} { variable ansi_wanted if {$ansi_wanted <= 0} { @@ -803,6 +1047,7 @@ namespace eval punk::console { #tailcall punk::ansi::a {*}$args ::punk::ansi::a {*}$args } + lappend PUNKARGS_aliases {::punk::console::code_a? ::punk::ansi::a?} proc code_a? {args} { variable ansi_wanted if {$ansi_wanted <= 0} { @@ -811,12 +1056,22 @@ namespace eval punk::console { tailcall ::punk::ansi::a? {*}$args } } + #proc a? {args} { + # #stdout + # variable ansi_wanted + # if {$ansi_wanted <= 0} { + # puts -nonewline [punk::ansi::ansistripraw [::punk::ansi::a?]] + # } else { + # tailcall ansi::a? {*}$args + # } + #} #REVIEW! this needs reworking. #It needs to be clarified as to what ansi off is supposed to do. #Turning ansi off only stops new ansi being generated - but what about codes stored in configurations of existing elements such as tables/frames? #It will stop underlines/bold/reverse as well as SGR colours #what about ansi movement codes etc? + #we already have colour on|off which disables SGR codes in a+ etc as well as stderr/stdout channel transforms proc ansi {{onoff {}}} { variable ansi_wanted if {[string length $onoff]} { @@ -837,13 +1092,14 @@ namespace eval punk::console { } default { set ansi_wanted 2 - } + } default { error "punk::console::ansi expected 0|1|on|off|true|false|yes|no|default" } } } catch {punk::repl::reset_prompt} + puts stderr "::punk::console::ansi - use 'colour' command to turn SGR codes on/off" return [expr {$ansi_wanted}] } @@ -876,38 +1132,36 @@ namespace eval punk::console { return [expr {!$colour_disabled}] } - - namespace eval ansi { - proc a {args} { - puts -nonewline [::punk::ansi::a {*}$args] - } - proc a? {args} { - puts -nonewline stdout [::punk::ansi::a? {*}$args] - } - proc a+ {args} { - puts -nonewline [::punk::ansi::a+ {*}$args] - } - proc clear {} { - puts -nonewline stdout [punk::ansi::clear] - } - proc clear_above {} { - puts -nonewline stdout [punk::ansi::clear_above] - } - proc clear_below {} { - puts -nonewline stdout [punk::ansi::clear_below] - } - proc clear_all {} { - puts -nonewline stdout [punk::ansi::clear_all] - } - proc reset {} { - puts -nonewline stdout [punk::ansi::reset] + #test - find a better place to set terminal type + variable is_vt52 0 + proc vt52 {{onoff {}}} { + #todo - return to colour state beforehand?. support 0-15 vt52 colours? + #we shouldn't have to trun off colour to enter vt52 - we should make punk::console emit correct codes + variable is_vt52 + if {$onoff eq ""} { + return $is_vt52 + } + if {![string is boolean -strict $onoff]} { + error "vt52 setting must be a boolean - or empty to query" + } + if {$is_vt52} { + if {!$onoff} { + puts -nonewline "\x1b<" + set is_vt52 0 + colour on + } + } else { + if {$onoff} { + unset_mode DECANM + set is_vt52 1 + colour off + } else { + puts -nonewline "\x1b<" + #emit even though our is_vt52 flag thinks it's on. Should be harmless if underlying terminal already vt100+ + } } + return $is_vt52 } - namespace import ansi::clear - namespace import ansi::clear_above - namespace import ansi::clear_below - namespace import ansi::clear_all - namespace import ansi::reset namespace eval local { proc set_codepage_output {cpname} { @@ -926,22 +1180,117 @@ namespace eval punk::console { error "set_codepage_input unimplemented on $::tcl_platform(platform)" } } + lappend PUNKARGS [list { + @id -id ::punk::console::local::echo + @cmd -name punk::console::local::echo -help\ + "Use stty on unix, or twapi on windows to set terminal + local input echo on/off - experimental" + @values -min 0 -max 1 + onoff -type boolean -default "" -help\ + "Omit or pass empty string to query current echo state." + }] + proc echo {args} { + set argd [punk::args::parse $args withid ::punk::console::local::echo] + set onoff [dict get $argd values onoff] + + set is_windows [string equal "windows" $::tcl_platform(platform)] + if {$onoff eq ""} { + #query + if {$is_windows} { + package require twapi + set inputstate [twapi::get_console_input_mode] + return [dict get $inputstate -echoinput] + } else { + #counterintuitively - the human format (-a) seems more consistent across platforms than the machine readable (-g) formats + #for now, quick and dirty look for echo in the list seems to work on wsl & freebsd at least. + set tstate [exec stty -a] + if {[lsearch $tstate echo] > 0} { + return 1 + } else { + return 0 + } + } + } else { + if {![string is boolean -strict $onoff]} { + error "::punk::console::local::echo requires boolean argument to set on or off" + } + if {$is_windows} { + set onoff [expr {true && $onoff}] ;#ensure true,yes etc are converted to 1|0 + set conh [twapi::get_console_handle stdin] + twapi::modify_console_input_mode $conh -echoinput $onoff + + return $onoff + } else { + if {$onoff} { + {*}[auto_execok stty] echo + return 1 + } else { + {*}[auto_execok stty] -echo + return 0 + } + } + } + } } namespace import local::set_codepage_output namespace import local::set_codepage_input + + lappend PUNKARGS [list { + @id -id ::punk::console::show_input_response + @cmd -name punk::console::show_input_response -help\ + "" + @opts + -terminal -default {stdin stdout} -type list -help\ + "terminal (currently list of in/out channels) (todo - object?)" + -expected_ms -type integer -default 500 -help\ + "Number of ms to wait for response" + @values -min 1 -max 1 + request -type string -help\ + "ANSI sequence such as \x1b\[?6n which + should elicit a response by the terminal + on stdin" + }] + proc show_input_response {args} { + set argd [punk::args::parse $args withid ::punk::console::show_input_response] + lassign [dict values $argd] leaders opts values received + set request [dict get $values request] + set inoutchannels [dict get $opts -terminal] + set expected [dict get $opts -expected_ms] + + set capturingregex {(((.*)))$} ;#capture entire response same as response-payload + set ts_start [clock millis] + set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex] + set ts_end [clock millis] + puts stderr $response + set out "" + dict for {k v} $response { + append out "$k [ansistring VIEW $v]" \n + } + append out "totalms [expr {$ts_end - $ts_start}]" + return $out + } + # -- --- --- --- --- --- --- #get_ansi_response functions - #review - can these functions sensibly be used on channels not attached to the local console? + #review - can these functions sensibly be used on channels not attached to the local console? #ie can we default to {stdin stdout} but allow other channel pairs? # -- --- --- --- --- --- --- proc get_cursor_pos {{inoutchannels {stdin stdout}}} { + if {$::punk::console::is_vt52} { + error "vt52 can't perform get_cursor_pos" + } #response from terminal #e.g \033\[46;1R set capturingregex {(.*)(\x1b\[([0-9]+;[0-9]+)R)$} ;#must capture prefix,entire-response,response-payload - set request "\033\[6n" - set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] + set request "\033\[6n" + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + #some terminals fail to respond properly to \x1b\[6n but do respond to \x1b\[?6n and vice-versa :/ + #todo - what? + #often terminals that fail will just put the raw request code on stdin - we could detect that and then + #try the other? + return $payload } proc get_checksum_rect {id page t l b r {inoutchannels {stdin stdout}}} { @@ -949,23 +1298,81 @@ namespace eval punk::console { #re e.g {(.*)(\x1b\[P44!~([[:alnum:]])\x1b\[\\)$} set capturingregex [string map [list %id% $id] {(.*)(\x1bP%id%!~([[:alnum:]]+)\x1b\\)$}] set request "\x1b\[${id}\;${page}\;$t\;$l\;$b\;$r*y" - set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] return $payload } proc get_device_status {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[([0-9]+)n)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[5n" - set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + return $payload + } + + variable last_da1_result "" + #TODO - 22? 28? 32? + #1 132 columns + #2 Printer port extension + #4 Sixel extension + #6 Selective erase + #7 DRCS + #8 UDK + #9 NRCS + #12 SCS extension + #15 Technical character set + #18 Windowing capability + #21 Horizontal scrolling + #23 Greek extension + #24 Turkish extension + #42 ISO Latin 2 character set + #44 PCTerm + #45 Soft key map + #46 ASCII emulation + + #https://vt100.net/docs/vt510-rm/DA1.html + # + proc get_device_attributes {{inoutchannels {stdin stdout}}} { + #DA1 + variable last_da1_result + #first element in result is the terminal's architectural class 61,62,63,64.. ? + #for vt100 we get things like: "ESC\[?1;0c" + #for vt102 "ESC\[?6c" + + #set capturingregex {(.*)(\x1b\[\?6[0-9][;]*([;0-9]+)c)$} ;#must capture prefix,entire-response,response-payload + set capturingregex {(.*)(\x1b\[\?([0-9]*[;0-9]+)c)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[c" + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + set last_da1_result $payload + return $payload + } + #https://vt100.net/docs/vt510-rm/DA2.html + proc get_device_attributes_secondary {{inoutchannels {stdin stdout}}} { + #DA2 + set capturingregex {(.*)(\x1b\[\>([0-9]*[;][0-9]*[;][0-1]c))$} ;#must capture prefix,entire-response,response-payload + #expect CSI > X;10|20;0|1c - docs suggest X should be something like 61. In practice we see 0 or 1 (windows) REVIEW + set request "\x1b\[>c" + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] return $payload } + proc get_device_attributes_tertiary {{inoutchannels {stdin stdout}}} { + #DA3 + set capturingregex {(.*)(\x1bP!\|([0-9]{8})\x1b\\)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[=c" + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + return $payload + } + proc get_terminal_id {{inoutchannels {stdin stdout}}} { + #DA3 - alias + get_device_attributes_tertiary $inoutchannels + } + proc get_tabstops {{inoutchannels {stdin stdout}}} { #DECTABSR \x1b\[2\$w #response example " ^[P2$u9/17/25/33/41/49/57/65/73/81^[\ " (where ^[ is \x1b) - #set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} + #set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} #set capturingregex {(.*)(\x1bP2$u((?:[0-9]+)*(?:\/[0-9]+)*)\x1b\\)$} set capturingregex {(.*)(\x1bP2\$u(.*)\x1b\\)$} set request "\x1b\[2\$w" - set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] set tabstops [split $payload "/"] return $tabstops } @@ -974,13 +1381,13 @@ namespace eval punk::console { #It's known this isn't always the case - but things like textutil::untabify2 take only a single value #on some systems test_char_width is a similar speed to get_tabstop_apparent_width - but on some test_char_width is much slower #we will use test_char_width as a fallback - proc get_tabstop_apparent_width {} { - set tslist [get_tabstops] + proc get_tabstop_apparent_width {{inoutchannels {stdin stdout}}} { + set tslist [get_tabstops $inoutchannels] if {![llength $tslist]} { #either terminal failed to report - or none set. set testw [test_char_width \t] if {[string is integer -strict $testw]} { - return $testw + return $testw } #We don't support none - default to 8 return 8 @@ -990,7 +1397,7 @@ namespace eval punk::console { if {[llength $tslist] == 1} { set testw [test_char_width \t] if {[string is integer -strict $testw]} { - return $testw + return $testw } return 8 } else { @@ -1028,57 +1435,168 @@ namespace eval punk::console { return [split [get_cursor_pos $inoutchannels] ";"] } - #todo - determine cursor on/off state before the call to restore properly. May only be possible + #todo - work out how to query terminal and set cell size in pixels + #for now use the windows default + variable cell_size + set cell_size "" + set cell_size_fallback 10x20 + + #todo - change -inoutchannels to -terminalobject with prebuilt default + + punk::args::define { + @id -id ::punk::console::cell_size + -inoutchannels -default {stdin stdout} -type list + @values -min 0 -max 1 + newsize -default "" -help\ + "character cell pixel dimensions WxH + or omit to query cell size." + } + proc cell_size {args} { + set argd [punk::args::get_by_id ::punk::console::cell_size $args] + set inoutchannels [dict get $argd opts -inoutchannels] + set newsize [dict get $argd values newsize] + + variable cell_size + if {$newsize eq ""} { + #query existing setting + if {$cell_size eq ""} { + #not set - try to query terminal's overall dimensions + set pixeldict [punk::console::get_xterm_pixels $inoutchannels] + lassign $pixeldict _w sw _h sh + if {[string is integer -strict $sw] && [string is integer -strict $sh]} { + lassign [punk::console::get_size] _cols columns _rows rows + #review - is returned size in pixels always a multiple of rows and cols? + set w [expr {$sw / $columns}] + set h [expr {$sh / $rows}] + set cell_size ${w}x${h} + return $cell_size + } else { + set cell_size $::punk::console::cell_size_fallback + puts stderr "punk::console::cell_size unable to query terminal for pixel data - using default $cell_size" + return $cell_size + } + } + return $cell_size + } + #newsize supplied - try to set + lassign [split [string tolower $newsize] x] w h + if {![string is integer -strict $w] || ![string is integer -strict $h] || $w < 1 || $h < 1} { + error "punk::sixel::cell_size error - expected format WxH where W and H are positive integers - got '$newsize'" + } + set cell_size ${w}x${h} + } + punk::args::define { + @id -id ::punk::console::test_is_vt52 + @cmd -name punk::console::test_is_vt52 -help\ + "in development.. broken" + -inoutchannels -default {stdin stdout} -type list + @values -min 0 -max 0 + } + + #only works in raw mode for windows terminal - (esc in output stripped?) why? + # works in line mode for alacrity and wezterm + proc test_is_vt52 {args} { + set argd [punk::args::get_by_id ::punk::console::test_is_vt52 $args] + set inoutchannels [dict get $argd opts -inoutchannels] + #ESC / K VT52 without printer + #ESC / M VT52 with printer + #ESC / Z VT52 emulator?? review + + #TODO + set capturingregex {(.*)(?:(\x1b\/(Z))|(\x1b\/(K))|(\x1b\/(M))|(\x1b\[\?([0-9;]+)c))$} ;#must capture prefix,entire-response,response-payload + #set capturingregex {(.*)(\x1b\[([0-9;]+)c)$} ;#must capture prefix,entire-response,response-payload + set request "\x1bZ" + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + #puts -->$payload<-- + return [expr {$payload in {Z K M}}] + } + + #todo - determine cursor on/off state before the call to restore properly. proc get_size {{inoutchannels {stdin stdout}}} { lassign $inoutchannels in out #we can't reliably use [chan names] for stdin,stdout. There could be stacked channels and they may have a names such as file22fb27fe810 #chan eof is faster whether chan exists or not than - if {[catch {chan eof $in} is_eof]} { - error "punk::console::get_size input channel $in seems to be closed ([info level 1])" - } else { - if {$is_eof} { - error "punk::console::get_size eof on input channel $in ([info level 1])" - } - } if {[catch {chan eof $out} is_eof]} { error "punk::console::get_size output channel $out seems to be closed ([info level 1])" } else { if {$is_eof} { error "punk::console::get_size eof on output channel $out ([info level 1])" - } + } + } + #we don't need to care about the input channel if chan configure on the output can give us the info. + #short circuit ansi cursor movement method if chan configure supports the -winsize value + set outconf [chan configure $out] + if {[dict exists $outconf -winsize]} { + #this mechanism is much faster than ansi cursor movements + #REVIEW check if any x-platform anomalies with this method? + #can -winsize key exist but contain erroneous info? We will check that we get 2 ints at least + lassign [dict get $outconf -winsize] cols lines + if {[string is integer -strict $cols] && [string is integer -strict $lines]} { + return [list columns $cols rows $lines] + } + #continue on to ansi mechanism if we didn't get 2 ints + } + + if {[catch {chan eof $in} is_eof]} { + error "punk::console::get_size input channel $in seems to be closed ([info level 1])" + } else { + if {$is_eof} { + error "punk::console::get_size eof on input channel $in ([info level 1])" + } } #keep out of catch - no point in even trying a restore move if we can't get start position - just fail here. + #no vt52 equiv? may as well strip all vt52 from here? lassign [get_cursor_pos_list $inoutchannels] start_row start_col - + variable is_vt52 + if {!$is_vt52} { + set movefunc "punk::ansi::move" + set func_coff "punk::ansi::cursor_off" + set func_con "punk::ansi::cursor_on" + } else { + set movefunc "punk::ansi::vt52move" + set func_coff "punk::ansi::cursor_off_vt52" + set func_con "punk::ansi::cursor_on_vt52" + } if {[catch { #some terminals (conemu on windows) scroll the viewport when we make a big move down like this - a move to 1 1 immediately after cursor_save doesn't seem to fix that. #This issue also occurs when switching back from the alternate screen buffer - so perhaps that needs to be addressed elsewhere. - puts -nonewline $out [punk::ansi::cursor_off][punk::ansi::move 2000 2000] + + puts -nonewline $out [$func_coff][$movefunc 2000 2000] lassign [get_cursor_pos_list $inoutchannels] lines cols - puts -nonewline $out [punk::ansi::move $start_row $start_col][punk::console::cursor_on];flush stdout - set result [list columns $cols rows $lines] + puts -nonewline $out [$movefunc $start_row $start_col][$func_con];flush stdout + set result [list columns $cols rows $lines] } errM]} { - puts -nonewline $out [punk::ansi::move $start_row $start_col] - puts -nonewline $out [punk::ansi::cursor_on] + puts -nonewline $out [$movefunc $start_row $start_col] + puts -nonewline $out [$func_con] error "$errM" } else { return $result } } - #faster - but uses cursor_save - which we may want to avoid if calling during another operation which uses cursor save/restore - proc get_size_cursorrestore {} { + #faster than get_size when it is using ansi mechanism - but uses cursor_save - which we may want to avoid if calling during another operation which uses cursor save/restore + proc get_size_cursorrestore {{inoutchannels {stdin stdout}}} { + lassign $inoutchannels in out + #we use the same shortcircuit mechanism as get_size to avoid ansi at all if the output channel will give us the info directly + set outconf [chan configure $out] + if {[dict exists $outconf -winsize]} { + lassign [dict get $outconf -winsize] cols lines + if {[string is integer -strict $cols] && [string is integer -strict $lines]} { + return [list columns $cols rows $lines] + } + } + if {[catch { #some terminals (conemu on windows) scroll the viewport when we make a big move down like this - a move to 1 1 immediately after cursor_save doesn't seem to fix that. #This issue also occurs when switching back from the alternate screen buffer - so perhaps that needs to be addressed elsewhere. - puts -nonewline [punk::ansi::cursor_off][punk::ansi::cursor_save_dec][punk::ansi::move 2000 2000] - lassign [get_cursor_pos_list] lines cols - puts -nonewline [punk::ansi::cursor_restore][punk::console::cursor_on];flush stdout - set result [list columns $cols rows $lines] + puts -nonewline $out [punk::ansi::cursor_off][punk::ansi::cursor_save_dec][punk::ansi::move 2000 2000] + lassign [get_cursor_pos_list $inoutchannels] lines cols + puts -nonewline $out [punk::ansi::cursor_restore][punk::console::cursor_on];flush $out + set result [list columns $cols rows $lines] } errM]} { - puts -nonewline [punk::ansi::cursor_restore_dec] - puts -nonewline [punk::ansi::cursor_on] + puts -nonewline $out [punk::ansi::cursor_restore_dec] + puts -nonewline $out [punk::ansi::cursor_on] error "$errM" } else { return $result @@ -1092,31 +1610,87 @@ namespace eval punk::console { proc get_xterm_size {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[8;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[18t" - set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] - lassign [split $payload {;}] rows cols + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + lassign [split $payload {;}] rows cols return [list columns $cols rows $rows] } + proc get_xterm_pixels {{inoutchannels {stdin stdout}}} { + set capturingregex {(.*)(\x1b\[4;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[14t" + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + lassign [split $payload {;}] height width + return [list width $width height $height] + } + + proc get_mode_line_wrap {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[\?7;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[?7\$p" - set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] return $payload } - - #Terminals generally default to LNM being reset (off) ie enter key sends a lone + #Terminals generally default to LNM being reset (off) ie enter key sends a lone #Terminals tested on windows either don't respond to this query, or respond with 0 (meaning mode not understood) #I presume from this that almost nobody is using LNM 1 (which sends both and ) proc get_mode_LNM {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[\?20;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[?20\$p" - set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] return $payload } + #DECRPM responses e.g: + # \x1b\[?7\;1\$y + # \x1b\[?7\;2\$y + #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + proc get_mode {num_or_name {inoutchannels {stdin stdout}}} { + if {[string is integer -strict $num_or_name]} { + set m $num_or_name + } else { + upvar ::punk::ansi::decmode_names decmode_names + if {[dict exists $decmode_names $num_or_name]} { + set m [dict get $decmode_names $num_or_name] + } else { + error "punk::console::get_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" + } + } + set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload + set request "\x1b\[?$m\$p" + set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] + return $payload + } + proc set_mode {num_or_name {inoutchannels {stdin stdout}}} { + if {[string is integer -strict $num_or_name]} { + set m $num_or_name + } else { + upvar ::punk::ansi::decmode_names decmode_names + if {[dict exists $decmode_names $num_or_name]} { + set m [dict get $decmode_names $num_or_name] + } else { + error "punk::console::set_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" + } + } + puts -nonewline "\x1b\[?${m}h" + } + proc unset_mode {num_or_name {inoutchannels {stdin stdout}}} { + if {[string is integer -strict $num_or_name]} { + set m $num_or_name + } else { + upvar ::punk::ansi::decmode_names decmode_names + if {[dict exists $decmode_names $num_or_name]} { + set m [dict get $decmode_names $num_or_name] + } else { + error "punk::console::unset_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" + } + } + puts -nonewline "\x1b\[?${m}l" + } + #terminals lie. This should be a reasonable (albeit relatively slow) test of actual width - but some terminals seem to miscalculate. #todo - a visual interactive test/questionnaire to ask user if things are lining up or if the terminal is telling fibs about cursor position. #todo - determine if these anomalies are independent of font - #punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. + #punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. + #review - vertical movements (e.g /n /v will cause emit 0 to be ineffective - todo - disallow?) proc test_char_width {char_or_string {emit 0}} { #return 1 #JMN @@ -1128,7 +1702,7 @@ namespace eval punk::console { } if {!$emit} { - puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1 + puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 } set response "" if {[catch { @@ -1144,7 +1718,14 @@ namespace eval punk::console { return } - puts -nonewline stdout $char_or_string + #On tcl9 - we could get an 'invalid or incomplete multibye or wide character' error + #e.g contains surrogate pair + if {[catch { + puts -nonewline stdout $char_or_string + } errM]} { + puts stderr "test_char_width couldn't emit this string - \nerror: $errM" + } + set response [punk::console::get_cursor_pos] lassign [split $response ";"] _row2 col2 if {![string is integer -strict $col2]} { @@ -1160,12 +1741,63 @@ namespace eval punk::console { return [expr {$col2 - $col1}] } + #get reported cursor position after emitting teststring. + #The row is more likely to be a lie than the column + #With wrapping on we should be able to test if the terminal has an inconsistency between reported width and when it actually wraps. + #(but as line wrapping generally occurs based on width - we probably won't see this - just 'apparently' early wrapping due to printing mismatch with width) + #unfortunately if terminal reports something like \u200B as width 1, but doesn't print it - we can't tell. (vs reporting 1 wide and printing replacement char/space) + #When cursor is already at bottom of screen, scrolling will occur so rowoffset will be zero + #we either need to move cursor up before test - or use alt screen ( or scroll_up then scroll_down?) + #for now we will use alt screen to reduce scrolling effects - REVIEW + proc test_string_cursor {teststring {emit 0}} { + variable ansi_available + if {!$ansi_available} { + puts stderr "No ansi - cannot test char_width of '$teststring' returning [string length $test_string]" + return [string length $teststring] + } + punk::console::enable_alt_screen + punk::console::move 0 0 + if {!$emit} { + puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 + } + set response "" + if {[catch { + set response [punk::console::get_cursor_pos] + } errM]} { + puts stderr "Cannot test_string_cursor for '[punk::ansi::ansistring VIEW $teststring]' - may be no console? Error message from get_cursor_pos: $errM" + return + } + lassign [split $response ";"] row1 col1 + if {![string length $response] || ![string is integer -strict $col1] || ![string is integer -strict $row1]} { + puts stderr "test_string_cursor Could not interpret response from get_cursor_pos for initial cursor pos. Response: '[punk::ansi::ansistring VIEW $response]'" + flush stderr + return + } + + puts -nonewline stdout $teststring + flush stdout + set response [punk::console::get_cursor_pos] + lassign [split $response ";"] row2 col2 + if {![string is integer -strict $col2] || ![string is integer -strict $row2]} { + puts stderr "test_string_cursor could not interpret response from get_cursor_pos for post-emit cursor pos. Response:'[punk::ansi::ansistring VIEW $response]'" + flush stderr + return + } + + if {!$emit} { + puts -nonewline stdout \033\[2K\033\[1G + } + flush stdout;#if we don't flush - a subsequent stderr write could move the cursor to a newline and interfere with our 2K1G erasure and cursor repositioning. + punk::console::disable_alt_screen + return [list rowoffset [expr {$col2 - $col1}] columnoffset [expr {$row2 - $row1}]] + } + #todo! - improve ideally we want to use VT sequences to determine - and make a separate utility for testing via systemcalls/os api proc test_can_ansi {} { #don't set ansi_avaliable here - we want to be able to change things, retest etc. if {"windows" eq "$::tcl_platform(platform)"} { if {[package provide twapi] ne ""} { - set h_out [twapi::get_console_handle stdout] + set h_out [twapi::get_console_handle stdout] set existing_mode [twapi::GetConsoleMode $h_out] if {[expr {$existing_mode & 4}]} { #virtual terminal processing happens to be enabled - so it's supported @@ -1176,12 +1808,12 @@ namespace eval punk::console { #try temporarily setting it - if we get an error - ansi not supported if {[catch { - twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] + twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] } errM]} { return 0 } #restore - twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] + twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] return 1 } else { #todo - try a cursorpos query and read stdin to see if we got a response? @@ -1200,20 +1832,61 @@ namespace eval punk::console { if {!$ansi_available} { return 0 } - set ansi_available [test_can_ansi] - return [expr {$ansi_available}] + #ansi_available defaults to -1 (unknown) + if {$ansi_available == -1} { + set ansi_available [test_can_ansi] + return $ansi_available + } + return 1 } - namespace eval ansi { - proc cursor_on {} { - puts -nonewline stdout [punk::ansi::cursor_on] + + variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested + #todo - flag to retest? (for consoles where grapheme cluster support can be disabled e.g via decmode 2027) + proc grapheme_cluster_support {} { + variable grapheme_cluster_support + if {[dict size $grapheme_cluster_support]} { + return $grapheme_cluster_support } - proc cursor_off {} { - puts -nonewline stdout [punk::ansi::cursor_off] + + if {[info exists ::env(TERM_PROGRAM)]} { + #terminals known to support grapheme clusters, but unable to respond to decmode request 2027 + #wezterm (on windows as at 2024-12 decmode 2027 doesn't work) + #REVIEW - what if terminal is remote wezterm? can/will this env variable + # iterm and apple terminal also set TERM_PROGRAM + if {[string tolower $::env(TERM_PROGRAM)] in [list wezterm]} { + set is_available 1 + return [dict create available 1 mode set] + } + } + #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + set state [get_mode grapheme_clusters] ;#decmode 2027 extension + set is_available 0 + switch -- $state { + 0 { + set m unsupported ;# the dec query is unsupported - but it's possible the terminal still has grapheme support + } + 1 { + set m set + set is_available 1 + } + 2 { + set m unset + } + 3 { + set m permanently_set + set is_available 1 + } + 4 { + set m permanently_unset + } + default { + set m "BAD_RESPONSE" + } } + return [dict create available $is_available mode $m] } - namespace import ansi::cursor_on - namespace import ansi::cursor_off + #review - the concept of using local mechanisms at all (ie apis) vs ansi is not necessarily something we want/need to support. #For the system to be really useful if needs to operate in conditions where the terminal is remote @@ -1224,10 +1897,10 @@ namespace eval punk::console { if {![catch {twapi::set_console_title $windowtitle} result]} { return $windowtitle } else { - error "punk::console::titleset failed to set title - try punk::console::ansi::titleset" + error "punk::console::local::titleset failed to set title - try punk::console::ansi::titleset" } } else { - error "punk::console::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset" + error "punk::console::local::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset" } } proc titleget {} { @@ -1235,34 +1908,16 @@ namespace eval punk::console { if {![catch {twapi::get_console_title} result]} { return $result } else { - error "punk::console::titleset failed to set title - ensure twapi is available" + error "punk::console::local::titleset failed to set title - ensure twapi is available" } } else { #titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title - # won't work on all platforms/terminals - but may be worth implementing - error "punk::console::titleget has no local mechanism to get the window title on this platform." + # won't work on all platforms/terminals - but may be worth implementing (for overtype::renderspace / frames etc) + error "punk::console::local::titleget has no local mechanism to get the window title on this platform." } } } - namespace eval ansi { - proc titleset {windowtitle} { - puts -nonewline stdout [punk::ansi::titleset $windowtitle] - } - } - #namespace import ansi::titleset - proc titleset {windowtitle} { - variable ansi_wanted - if { $ansi_wanted <= 0} { - punk::console::local::titleset $windowtitle - } else { - tailcall ansi::titleset $windowtitle - } - } - #no known pure-ansi solution - proc titleget {} { - return [local::titleget] - } proc infocmp {} { set cmd1 [auto_execok infocmp] @@ -1285,14 +1940,14 @@ namespace eval punk::console { #todo - compare speed with get_cursor_pos - work out why the big difference proc test_cursor_pos {} { - if {!$::punk::console::is_raw} { + if {![tsv::get console is_raw]} { set was_raw 0 enableRaw } else { set was_raw 1 } puts -nonewline stdout \033\[6n ;flush stdout - fconfigure stdin -blocking 0 + chan configure stdin -blocking 0 set info [read stdin 20] ;# after 1 if {[string first "R" $info] <=0} { @@ -1305,16 +1960,113 @@ namespace eval punk::console { return [split $data ";"] } + #channel? namespace eval ansi { + variable PUNKARGS + #ansi escape sequence based terminal/console control functions + namespace export * + + #proc a {args} { + # puts -nonewline [::punk::ansi::a {*}$args] + #} + #proc a+ {args} { + # puts -nonewline [::punk::ansi::a+ {*}$args] + #} + #proc a? {args} { + # puts -nonewline stdout [::punk::ansi::a? {*}$args] + #} + proc clear {} { + puts -nonewline stdout [punk::ansi::clear] + } + proc clear_above {} { + puts -nonewline stdout [punk::ansi::clear_above] + } + proc clear_below {} { + puts -nonewline stdout [punk::ansi::clear_below] + } + proc clear_all {} { + puts -nonewline stdout [punk::ansi::clear_all] + } + proc reset {} { + puts -nonewline stdout [punk::ansi::reset] + } + proc cursor_on {} { + upvar ::punk::console::is_vt52 is_vt52 + if {!$is_vt52} { + puts -nonewline stdout [punk::ansi::cursor_on] + } else { + puts -nonewline stdout [punk::ansi::cursor_on_vt52] + } + } + proc cursor_off {} { + upvar ::punk::console::is_vt52 is_vt52 + if {!$is_vt52} { + puts -nonewline stdout [punk::ansi::cursor_off] + } else { + puts -nonewline stdout [punk::ansi::cursor_off_vt52] + } + } + + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::move + @cmd -name punk::console::move -help\ + {Return an ANSI or vt52 sequence to move cursor to row,col + (aka: cursor home) + + The sequence emitted will depend on the mode of the + terminal as stored in the consolehandle. + Directly setting the mode via raw escape sequences: + e.g unset_mode DECANM for vt52 + or puts \x1b< to return to ANSI + will not necessarily update the application of + the change in terminal state. Major state changes + such as this should be done via provided functions + that keep the REPL state in sync with the underlying + terminal state. + + For ANSI the sequence is of the form: + ESC[;H + (CSI row ; col H) + This sequence will generally not be understood by + terminals that are in vt52 mode. + + For VT52 the sequence is of the form: + ESCY + This sequence will generally not be understood by + terminals that are not in vt52 mode even if higher + modes are supported. + + } + @values -min 2 -max 2 + row -type integer -help\ + "row number - starting at 1" + col -type integer -help\ + "column number - starting at 1" + }] proc move {row col} { - puts -nonewline stdout [punk::ansi::move $row $col] + upvar ::punk::console::is_vt52 is_vt52 + if {!$is_vt52} { + return [punk::ansi::move $row $col] + } else { + return [punk::ansi::vt52move $row $col] + } } proc move_forward {n} { - puts -nonewline stdout [punk::ansi::move_forward $n] + upvar ::punk::console::is_vt52 is_vt52 + if {!$is_vt52} { + puts -nonewline stdout [punk::ansi::move_forward $n] + } else { + puts -nonewline stdout [punk::ansi::vt52move_forward $n] + } } proc move_back {n} { - puts -nonewline stdout [punk::ansi::move_back $n] + upvar ::punk::console::is_vt52 is_vt52 + if {!$is_vt52} { + puts -nonewline stdout [punk::ansi::move_back $n] + } else { + puts -nonewline stdout [punk::ansi::vt52move_back $n] + } } proc move_up {n} { puts -nonewline stdout [punk::ansi::move_up $n] @@ -1323,21 +2075,101 @@ namespace eval punk::console { puts -nonewline stdout [punk::ansi::move_down $n] } proc move_column {col} { - puts -nonewline stdout [punk::ansi::move_column $col] + upvar ::punk::console::is_vt52 is_vt52 + if {!$is_vt52} { + puts -nonewline stdout [punk::ansi::move_column $col] + } else { + puts -nonewline stdout [punk::ansi::vt52move_column $col] + } } proc move_row {row} { - puts -nonewline stdout [punk::ansi::move_row $col] + puts -nonewline stdout [punk::ansi::move_row $row] } proc move_emit {row col data args} { - puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args] + upvar ::punk::console::is_v52 is_vt52 + if {!$is_vt52} { + puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args] + } else { + puts -nonewline stdout [punk::ansi::v52move_emit $row $col $data {*}$args] + } } proc move_emit_return {row col data args} { + #todo detect if in raw mode or not? + set is_in_raw 0 lassign [punk::console::get_cursor_pos_list] orig_row orig_col - set out "" - append out [punk::ansi::move_emit $row $col $data {*}$args] + + set commands "" + append commands [punk::ansi::move_emit $row $col $data {*}$args] + foreach {row col data} $args { + append commands [punk::ansi::move_emit $row $col $data {*}$args] + } if {!$is_in_raw} { incr orig_row -1 } + append commands [punk::ansi::move $orig_row $orig_col] + puts -nonewline stdout $commands + return "" + } + proc move_emitblock_return {row col textblock} { + lassign [punk::console::get_cursor_pos_list] orig_row orig_col + + set commands "" + foreach ln [split $textblock \n] { + append commands [punk::ansi::move_emit $row $col $ln] + incr row + } + append commands [punk::ansi::move $orig_row $orig_col] + puts -nonewline $commands + return + } + #we can be (slightly?) faster and more efficient if we use the consoles cursor_save_dec command - but each savecursor overrides any previous one. + #leave cursor_off/cursor_on to caller who can wrap more efficiently.. + proc cursorsave_move_emit_return {row col data args} { + upvar ::punk::console::is_vt52 is_vt52 + #JMN + set commands "" + if {!$is_vt52} { + append commands [punk::ansi::cursor_save_dec] + append commands [punk::ansi::move_emit $row $col $data] + foreach {row col data} $args { + append commands [punk::ansi::move_emit $row $col $data] + } + append commands [punk::ansi::cursor_restore_dec] + } else { + append commands [punk::ansi::cursor_save_vt52] + append commands [punk::ansi::vt52move_emit $row $col $data] + foreach {row col data} $args { + append commands [punk::ansi::vt52move_emit $row $col $data] + } + append commands [punk::ansi::cursor_restore_vt52] + } + puts -nonewline stdout $commands; flush stdout + } + proc cursorsave_move_emitblock_return {row col textblock} { + set commands "" + upvar ::punk::console::is_vt52 is_vt52 + if {!$is_vt52} { + append commands [punk::ansi::cursor_save_dec] + foreach ln [split $textblock \n] { + append commands [punk::ansi::move_emit $row $col $ln] + incr row + } + append commands [punk::ansi::cursor_restore_dec] + } else { + append commands [punk::ansi::cursor_save_vt52] + foreach ln [split $textblock \n] { + append commands [punk::ansi::vt52move_emit $row $col $ln] + incr row + } + append commands [punk::ansi::cursor_restore_vt52] + } + puts -nonewline stdout $commands;flush stdout + return + } + proc move_call_return {row col script} { + lassign [punk::console::get_cursor_pos_list] orig_row orig_col + move $row $col + uplevel 1 $script move $orig_row $orig_col } proc scroll_up {n} { @@ -1358,12 +2190,12 @@ namespace eval punk::console { proc cursor_save {} { #*** !doctools #[call [fun cursor_save]] - puts -nonewline \x1b\[s + puts -nonewline stdout \x1b\[s } proc cursor_restore {} { #*** !doctools #[call [fun cursor_restore]] - puts -nonewline \x1b\[u + puts -nonewline stdout \x1b\[u } #DEC equivalents of cursor_save/cursor_restore - perhaps more widely supported? proc cursor_save_dec {} { @@ -1392,132 +2224,86 @@ namespace eval punk::console { proc delete_lines {count} { puts -nonewline \x1b\[${count}M } + proc titleset {windowtitle} { + puts -nonewline stdout [punk::ansi::titleset $windowtitle] + } + proc test_decaln {} { + puts -nonewline stdout [punk::ansi::test_decaln] + } + } + namespace import ::punk::console::ansi::* + catch {rename titleset ""} + #namespace import ansi::titleset + proc titleset {windowtitle} { + variable ansi_wanted + if { $ansi_wanted <= 0} { + punk::console::local::titleset $windowtitle + } else { + ansi::titleset $windowtitle + } } - namespace import ansi::move - namespace import ansi::move_emit - namespace import ansi::move_forward - namespace import ansi::move_back - namespace import ansi::move_up - namespace import ansi::move_down - namespace import ansi::move_column - namespace import ansi::move_row - namespace import ansi::cursor_save - namespace import ansi::cursor_restore - namespace import ansi::cursor_save_dec - namespace import ansi::cursor_restore_dec - namespace import ansi::scroll_up - namespace import ansi::scroll_down - namespace import ansi::enable_alt_screen - namespace import ansi::disable_alt_screen - namespace import ansi::insert_spaces - namespace import ansi::delete_characters - namespace import ansi::erase_characters - namespace import ansi::insert_lines - namespace import ansi::delete_lines - - interp alias {} smcup {} ::punk::console::enable_alt_screen - interp alias {} rmcup {} ::punk::console::disable_alt_screen + #no known pure-ansi solution + proc titleget {} { + return [local::titleget] + } + + foreach ansicmd [list ::punk::console::ansi::move] { + set ctail [namespace tail $ansicmd] + set arglist [info args $ansicmd] + set argcall "" + if {[llength $arglist]} { + foreach a [lrange $arglist 0 end-1] { + append argcall "\$$a " + } + if {[lindex $arglist end] eq "args"} { + append argcall {{*}$args} + } else { + append argcall "\$[lindex $arglist end]" + } + } + catch {rename $ctail ""} + proc $ctail $arglist [string map [list %ansicmd% $ansicmd %argcall% $argcall] { + puts -nonewline [%ansicmd% %argcall%] + }] + } + + #experimental proc rhs_prompt {col text} { package require textblock - lassign [textblock::size $text] _w tw _h th + lassign [textblock::size $text] _w tw _h th if {$th > 1} { #move up first.. need to know current line? } #set blanks [string repeat " " [expr {$col + $tw}]] #puts -nonewline [punk::ansi::erase_eol]$blanks;move_emit_return this $col $text #puts -nonewline [move_emit_return this $col [punk::ansi::insert_spaces 150]$text] - cursor_save_dec + cursor_save_dec #move_emit_return this $col [punk::ansi::move_forward 50][punk::ansi::insert_spaces 150][punk::ansi::move_back 50][punk::ansi::move_forward $col]$text #puts -nonewline [punk::ansi::insert_spaces 150][punk::ansi::move_column $col]$text puts -nonewline [punk::ansi::erase_eol][punk::ansi::move_column $col]$text cursor_restore } - proc move_emit_return {row col data args} { - #todo detect if in raw mode or not? - set is_in_raw 0 - lassign [punk::console::get_cursor_pos_list] orig_row orig_col - set commands "" - append commands [punk::ansi::move_emit $row $col $data] - foreach {row col data} $args { - append commands [punk::ansi::move_emit $row $col $data] - } - if {!$is_in_raw} { - incr orig_row -1 - } - append commands [punk::ansi::move $orig_row $orig_col] - puts -nonewline stdout $commands - return "" - } - #we can be (slightly?) faster and more efficient if we use the consoles cursor_save_dec command - but each savecursor overrides any previous one. - #leave cursor_off/cursor_on to caller who can wrap more efficiently.. - proc cursorsave_move_emit_return {row col data args} { - set commands "" - append commands [punk::ansi::cursor_save_dec] - append commands [punk::ansi::move_emit $row $col $data] - foreach {row col data} $args { - append commands [punk::ansi::move_emit $row $col $data] - } - append commands [punk::ansi::cursor_restore_dec] - puts -nonewline stdout $commands; flush stdout - } - proc move_emitblock_return {row col textblock} { + #this doesn't work - we would need an internal virtual screen structure to pick up cursor attributes from arbitrary locations? + # ncurses and its ilk may have something like that - but we specifically want to avoid curses libraries + proc pick {row col} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col - - set commands "" - foreach ln [split $textblock \n] { - append commands [punk::ansi::move_emit $row $col $ln] - incr row - } - append commands [punk::ansi::move $orig_row $orig_col] - puts -nonewline $commands - return - } - proc cursorsave_move_emitblock_return {row col textblock} { - set commands "" - append commands [punk::ansi::cursor_save_dec] - foreach ln [split $textblock \n] { - append commands [punk::ansi::move_emit $row $col $ln] - incr row - } - append commands [punk::ansi::cursor_restore_dec] - puts -nonewline stdout $commands;flush stdout - return + set test "" + #set test [a green Yellow] + move_emit $row $col $test\0337 + puts -nonewline \0338\033\[${orig_row}\;${orig_col}H } - proc move_call_return {row col script} { + proc pick_emit {row col data} { + set test "" + #set test [a green Purple] lassign [punk::console::get_cursor_pos_list] orig_row orig_col - move $row $col - uplevel 1 $script - move $orig_row $orig_col + move_emit $row $col $test\0337 + puts -nonewline \0338\033\[${orig_row}\;${orig_col}H$data } - #this doesn't work - we would need an internal virtual screen structure to pick up cursor attributes from arbitrary locations? - # ncurses and its ilk may have something like that - but we specifically want to avoid curses libraries - proc pick {row col} { - lassign [punk::console::get_cursor_pos_list] orig_row orig_col - set test "" - #set test [a green Yellow] - move_emit $row $col $test\0337 - puts -nonewline \0338\033\[${orig_row}\;${orig_col}H - } - proc pick_emit {row col data} { - set test "" - #set test [a green Purple] - lassign [punk::console::get_cursor_pos_list] orig_row orig_col - move_emit $row $col $test\0337 - puts -nonewline \0338\033\[${orig_row}\;${orig_col}H$data - } - # -- --- --- --- --- --- - namespace eval ansi { - proc test_decaln {} { - puts -nonewline stdout [punk::ansi::test_decaln] - } - } - namespace import ansi::test_decaln - namespace eval clock { #map chars of chars "0" to "?"" ie 0x30 to x3f @@ -1537,7 +2323,7 @@ namespace eval punk::console { 18 30 60 C0 60 30 18 00 00 00 7E 00 7E 00 00 00 60 30 18 0C 18 30 60 00 - 3C 66 0C 18 18 00 18 00 + 3C 66 0C 18 18 00 18 00 } #libungif extras append fontmap1 { @@ -1705,7 +2491,7 @@ namespace eval punk::console { #curses attr off reverse #a noreverse set reverse 0 - set output "" + set output "" set charno 0 foreach char [split $str {}] { binary scan $char c f @@ -1742,9 +2528,9 @@ namespace eval punk::console { } proc display {} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col - punk::console::move 20 20 + punk::console::move 20 20 punk::console::clear_above - punk::console::move 0 0 + punk::console::move 0 0 puts -nonewline [bigstr [clock format [clock seconds] -format %H:%M:%S] 10 5] punk::console::move $orig_row $orig_col @@ -1753,9 +2539,9 @@ namespace eval punk::console { proc displaystr {str} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col - punk::console::move 20 20 + punk::console::move 20 20 punk::console::clear_above - punk::console::move 0 0 + punk::console::move 0 0 puts -nonewline [bigstr $str 10 5] punk::console::move $orig_row $orig_col @@ -1774,7 +2560,7 @@ namespace eval punk::console { puts stderr "punk::console WARNING: no modern unicode support in this Tcl version. High unicode values not properly supported. (string length \\U00010000 : $high_unicode_length should be 1)" } else { set can_high_unicode 1 - set can_regex_high_unicode [string match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] + set can_regex_high_unicode [string equal [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] if {!$can_regex_high_unicode} { puts stderr "punk::console warning: TCL version cannot perform braced regex of high unicode" } @@ -1785,13 +2571,13 @@ namespace eval punk::console { if {$dingbat_heavy_plus_width == 2} { set can_terminal_report_dingbat_width 1 } else { - puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." + puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." } set diacritic_width [punk::console::test_char_width a\u0300] if {$diacritic_width == 1} { set can_terminal_report_diacritic_width 1 } else { - puts stderr "punk::console warning: terminal unable to report diacritic width properly." + puts stderr "punk::console warning: terminal unable to report diacritic width properly." } if {$can_high_unicode && $can_regex_high_unicode && $can_terminal_report_dingbat_width && $can_terminal_report_diacritic_width} { @@ -1803,19 +2589,64 @@ namespace eval punk::console { } #run the test and allow warnings to be emitted to stderr on package load. User should know the terminal and/or Tcl version are not optimal for unicode character work #set testresult [test1] -} + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::console ---}] +} +namespace eval punk::console::check { + variable has_bug_legacysymbolwidth -1 ;#undetermined + proc has_bug_legacysymbolwidth {} { + #some terminals (on windows as at 2024) miscount width of these single-width blocks internally + #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) + #This was fixed in windows-terminal based systems (2021) but persists in others. + #https://github.com/microsoft/terminal/issues/11694 + variable has_bug_legacysymbolwidth + if {!$has_bug_legacysymbolwidth} { + return 0 + } + if {$has_bug_legacysymbolwidth == -1} { + #run the test using ansi movement + #we only test a specific character from the known problematic set + set w [punk::console::test_char_width \U1fb7d] + if {$w == 1} { + set has_bug_legacysymbolwidth 0 + } else { + #can return 2 on legacy window consoles for example + set has_bug_legacysymbolwidth 1 + } + return $has_bug_legacysymbolwidth + } + return 1 + } + variable has_bug_zwsp -1 ;#undetermined + proc has_bug_zwsp {} { + #Note that some terminals behave differently regarding a leading zwsp vs one that is inline between other chars. + #we are only testing the inline behaviour here. + variable has_bug_zwsp + if {!$has_bug_zwsp} { + return 0 + } + if {$has_bug_zwsp == -1} { + set w [punk::console::test_char_width X\u200bY] + } + if {$w == 2} { + return 0 + } else { + #may return 3 - but this gives no indication of whether terminal hides it or not. + return 1 + } + return 1 + } -interp alias {} colour {} punk::console::colour -interp alias {} ansi {} punk::console::ansi -interp alias {} color {} punk::console::colour -interp alias {} a+ {} punk::console::code_a+ -interp alias {} a {} punk::console::code_a -interp alias {} a? {} punk::console::code_a? +} +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::console ::punk::console::internal ::punk::console::local ::punk::console::ansi +} @@ -1825,4 +2656,7 @@ package provide punk::console [namespace eval punk::console { variable version set version 0.1.1 }] -return \ No newline at end of file +return + +#*** !doctools +#[manpage_end] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/docgen-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/docgen-0.1.0.tm index f4d26342..cea2d287 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/docgen-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/docgen-0.1.0.tm @@ -31,6 +31,7 @@ namespace eval punk::docgen { error "get_doctools_comments file '$fname' not found" } set fd [open $fname r] + chan conf $fd -translation binary set data [read $fd] close $fd if {![string match "*#\**!doctools*" $data]} { diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm index f0e96a28..adb47eff 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm @@ -19,6 +19,7 @@ ##e.g package require frobz package require punk::mix::base package require struct::set +package require punk::args namespace eval punk::du { @@ -486,29 +487,158 @@ namespace eval punk::du { return [lindex [lappend winfile_attributes $bitmask [twapi::decode_file_attributes $bitmask]] end] } } - proc attributes_twapi {path {detail basic}} { + variable win_reparse_tags + #implied prefix for all names IO_REPARSE_TAG_ + #list of reparse tags: https://learn.microsoft.com/en-us/openspecs/windows_protocols/ms-fscc/c8e77b37-3909-4fe6-a4ea-2b9d423b1ee4 + set win_reparse_tags [dict create\ + RESERVED_ZERO [list hex 0x00000000 obsolete 0 serverside 0 meaning "Reserved reparse tag value"]\ + RESERVED_ONE [list hex 0x00000001 obsolete 0 serverside 0 meaning "Reserved reparse tag value"]\ + RESERVED_TWO [list hex 0x00000002 obsolete 0 serverside 0 meaning "Reserved reparse tag value"]\ + MOUNT_POINT [list hex 0xA0000003 obsolete 0 serverside 0 meaning "Used for mount point support"]\ + HSM [list hex 0xC0000004 obsolete 1 serverside 0 meaning "Obsolete. Used by legacy Hierarchical Storage Manager Product"]\ + DRIVE_EXTENDER [list hex 0x80000005 obsolete 0 serverside 0 meaning "Home server drive extender"]\ + HSM2 [list hex 0xC0000006 obsolete 1 serverside 0 meaning "Obsolete. Used by legacy Hierarchical Storage Manager Product"]\ + SIS [list hex 0x80000007 obsolete 0 serverside 1 meaning "Used by single-instance storage (SIS) filter driver."]\ + WIM [list hex 0x80000008 obsolete 0 serverside 1 meaning "Used by the WIM Mount filter."]\ + CSV [list hex 0x80000008 obsolete 1 serverside 1 meaning "Obsolete. Used by Clustered Shared Volumes (CSV) version 1 in Windows Server 2008 R2 operating system. "]\ + DFS [list hex 0x8000000A obsolete 0 serverside 1 meaning "Used by the DFS filter. The DFS is described in the Distributed File System (DFS): Referral Protocol Specification \[MS-DFSC\]."]\ + FILTER_MANAGER [list hex 0x8000000B obsolete 0 serverside 0 meaning "Used by filter manager test harness"]\ + SYMLINK [list hex 0xA000000C obsolete 0 serverside 0 meaning "Used for symbolic link support."]\ + IIS_CACHE [list hex 0xA0000010 obsolete 0 serverside 1 meaning "Used by Microsoft Internet Information Services (IIS) caching. "]\ + DFSR [list hex 0x80000012 obsolete 0 serverside 1 meaning "Used by the DFS filter. The DFS is described in \[MS-DFSC\]. "]\ + DEDUP [list hex 0x80000013 obsolete 0 serverside 1 meaning "Used by the Data Deduplication (Dedup) filter. "]\ + APPXSTRM [list hex 0xC0000014 obsolete 0 serverside 0 meaning "Not used."]\ + NFS [list hex 0x80000014 obsolete 0 serverside 1 meaning "Used by the Network File System (NFS) component. "]\ + FILE_PLACEHOLDER [list hex 0x80000015 obsolete 1 serverside 1 meaning "Obsolete. Used by Windows Shell for legacy placeholder files in Windows 8.1. "]\ + DFM [list hex 0x80000016 obsolete 0 serverside 1 meaning "Used by the Dynamic File filter. "]\ + WOF [list hex 0x80000017 obsolete 0 serverside 1 meaning "Used by the Windows Overlay filter, for either WIMBoot or single-file compression."]\ + WCI [list hex 0x80000018 obsolete 0 serverside 1 meaning "Used by the Windows Container Isolation filter. "]\ + WCI_2 [list hex 0x90001018 obsolete 0 serverside 1 meaning "Used by the Windows Container Isolation filter. "]\ + GLOBAL_REPARSE [list hex 0xA0000019 obsolete 0 serverside 1 meaning "Used by NPFS to indicate a named pipe symbolic link from a server silo into the host silo."]\ + CLOUD [list hex 0x9000001A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_1 [list hex 0x9000101A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_2 [list hex 0x9000201A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_3 [list hex 0x9000301A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_4 [list hex 0x9000401A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_5 [list hex 0x9000501A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_6 [list hex 0x9000601A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_7 [list hex 0x9000701A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_8 [list hex 0x9000801A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_9 [list hex 0x9000901A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_A [list hex 0x9000A01A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_B [list hex 0x9000B01A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_C [list hex 0x9000C01A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_D [list hex 0x9000D01A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_E [list hex 0x9000E01A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + CLOUD_F [list hex 0x9000F01A obsolete 0 serverside 1 meaning "Used by the Cloud Files filter, for files managed by a sync engine such as Microsoft OneDrive."]\ + APPEXECLINK [list hex 0x8000001B obsolete 0 serverside 1 meaning "Used by Universal Windows Platform (UWP) packages to encode information that allows the application to be launched by CreateProcess."]\ + PROJFS [list hex 0x9000001C obsolete 0 serverside 1 meaning "Used by the Windows Projected File System filter, for files managed by a user mode provider such as VFS for Git."]\ + LX_SYMLINK [list hex 0xA000001D obsolete 0 serverside 1 meaning "Used by the Windows Subsystem for Linux (WSL) to represent a UNIX symbolic link."]\ + STORAGE_SYNC [list hex 0x8000001E obsolete 0 serverside 1 meaning "Used by the Azure File Sync (AFS) filter."]\ + WCI_TOMBSTONE [list hex 0xA000001F obsolete 0 serverside 1 meaning "Used by the Windows Container Isolation filter."]\ + UNHANDLED [list hex 0x80000020 obsolete 0 serverside 1 meaning "Used by the Windows Container Isolation filter."]\ + ONEDRIVE [list hex 0x80000021 obsolete 0 serverside 0 meaning "Not used"]\ + PROJFS_TOMBSTONE [list hex 0xA0000022 obsolete 0 serverside 1 meaning "Used by the Windows Projected File System filter, for files managed by a user mode provider such as VFS for Git."]\ + AF_UNIX [list hex 0x80000023 obsolete 0 serverside 1 meaning "Used by the Windows Subsystem for Linux (WSL) to represent a UNIX domain socket."]\ + LX_FIFO [list hex 0x80000024 obsolete 0 serverside 1 meaning "Used by the Windows Subsystem for Linux (WSL) to represent a UNIX FIFO (named pipe)."]\ + LX_CHR [list hex 0x80000025 obsolete 0 serverside 1 meaning "Used by the Windows Subsystem for Linux (WSL) to represent a UNIX character special file."]\ + LX_BLK [list hex 0x80000026 obsolete 0 serverside 1 meaning "Used by the Windows Subsystem for Linux (WSL) to represent a UNIX block special file."]\ + WCI_LINK [list hex 0xA0000027 obsolete 0 serverside 1 meaning "Used by the Windows Container Isolation filter."]\ + WCI_LINK_1 [list hex 0xA0001027 obsolete 0 serverside 1 meaning "Used by the Windows Container Isolation filter."]\ + ] + variable win_reparse_tags_by_int + dict for {k v} $win_reparse_tags { + set intkey [expr {[dict get $v hex]}] + set info [dict merge [dict create tag $k] $v] ;#put tag at front + dict set win_reparse_tags_by_int $intkey $info + } + + #https://stackoverflow.com/questions/46383428/get-the-immediate-target-path-from-symlink-reparse-point + #need to call twapi::create_file with FILE_FLAG_OPEN_REPARSE_POINT 0x00200000 + #then twapi::device_ioctl (win32 DeviceIoControl) + #then parse buffer somehow (binary scan..) + #https://learn.microsoft.com/en-us/openspecs/windows_protocols/ms-fscc/b41f1cbf-10df-4a47-98d4-1c52a833d913 + + proc Get_attributes_from_iteminfo {args} { + variable win_reparse_tags_by_int + + set argd [punk::args::get_dict { + @id -id ::punk::du::lib::Get_attributes_from_iteminfo + -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" + -debugchannel -default stderr -help "channel to write debug output, or none to append to output" + @values -min 1 -max 1 + iteminfo -help "iteminfo dict as set by 'twapi::find_file_next iteminfo'" + } $args] + set opts [dict get $argd opts] + set iteminfo [dict get $argd values iteminfo] + set opt_debug [dict get $opts -debug] + set opt_debugchannel [dict get $opts -debugchannel] + #-longname is placeholder - caller needs to set + set result [dict create -archive 0 -hidden 0 -longname [dict get $iteminfo name] -readonly 0 -shortname {} -system 0] + if {$opt_debug} { + set dbg "iteminfo returned by find_file_open\n" + append dbg [pdict -channel none iteminfo] + if {$opt_debugchannel eq "none"} { + dict set result -debug $dbg + } else { + puts -nonewline $opt_debugchannel $dbg + } + + } + + set attrinfo [decode_win_attributes [dict get $iteminfo attrs]] + if {"hidden" in $attrinfo} { + dict set result -hidden 1 + } + if {"system" in $attrinfo} { + dict set result -system 1 + } + if {"readonly" in $attrinfo} { + dict set result -readonly 1 + } + dict set result -shortname [dict get $iteminfo altname] + dict set result -fileattributes $attrinfo + if {"reparse_point" in $attrinfo} { + #the twapi API splits this 32bit value for us + set low_word [dict get $iteminfo reserve0] + set high_word [dict get $iteminfo reserve1] + # 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 + # 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 + #+-+-+-+-+-----------------------+-------------------------------+ + #|M|R|N|R| Reserved bits | Reparse tag value | + #+-+-+-+-+-----------------------+-------------------------------+ + #todo - is_microsoft from first bit of high_word + set low_int [expr {$low_word}] ;#review - int vs string rep for dict key lookup? does it matter? + if {[dict exists $win_reparse_tags_by_int $low_int]} { + dict set result -reparseinfo [dict get $win_reparse_tags_by_int $low_int] + } else { + dict set result -reparseinfo [dict create tag "" hex 0x[format %X $low_int] meaning "unknown reparse tag int:$low_int"] + } + } + dict set result -raw $iteminfo + return $result + } + + + proc attributes_twapi {args} { + set argd [punk::args::get_dict { + @id -id ::punk::du::lib::attributes_twapi + -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" + -debugchannel -default stderr -help "channel to write debug output, or none to append to output" + -detail -default basic -choices {basic full} -help "full returns also the altname/shortname field" + @values -min 1 -max 1 + path -help "path to file or folder for which to retrieve attributes" + } $args] + set opts [dict get $argd opts] + set path [dict get $argd values path] + set opt_detail [dict get $opts -detail] + set opt_debug [dict get $opts -debug] + set opt_debugchannel [dict get $opts -debugchannel] + try { - set iterator [twapi::find_file_open $path -detail $detail] ;# -detail full only adds data to the altname field + set iterator [twapi::find_file_open $path -detail $opt_detail] ;# -detail full only adds data to the altname field if {[twapi::find_file_next $iterator iteminfo]} { - set attrinfo [decode_win_attributes [dict get $iteminfo attrs]] - set result [dict create -archive 0 -hidden 0 -longname $path -readonly 0 -shortname {} -system 0] - if {"hidden" in $attrinfo} { - dict set result -hidden 1 - } - if {"system" in $attrinfo} { - dict set result -system 1 - } - if {"readonly" in $attrinfo} { - dict set result -readonly 1 - } - dict set result -shortname [dict get $iteminfo altname] - dict set result -rawflags $attrinfo - set extras [list] - #foreach prop {ctime atime mtime size} { - # lappend extras $prop [dict get $iteminfo $prop] - #} - #dict set result -extras $extras - dict set result -raw $iteminfo + set result [Get_attributes_from_iteminfo -debug $opt_debug -debugchannel $opt_debugchannel $iteminfo] return $result } else { error "could not read attributes for $path" @@ -519,13 +649,14 @@ namespace eval punk::du { } #todo - review 'errors' key. We have errors relating to containing folder and args vs per child-item errors - additional key needed? - namespace export du_dirlisting_twapi du_dirlisting_generic du_dirlisting_unix du_dirlisting_undecided + namespace export attributes_twapi du_dirlisting_twapi du_dirlisting_generic du_dirlisting_unix du_dirlisting_undecided du_dirlisting_tclvfs # get listing without using unix-tools (may not be installed on the windows system) # this dirlisting is customised for du - so only retrieves dirs,files,filesizes (minimum work needed to perform du function) # This also preserves path rep for elements in the dirs/folders keys etc - which can make a big difference in performance proc du_dirlisting_twapi {folderpath args} { set defaults [dict create\ -glob *\ + -filedebug 0\ -with_sizes 1\ -with_times 1\ ] @@ -534,6 +665,9 @@ namespace eval punk::du { set opt_glob [dict get $opts -glob] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_with_sizes [dict get $opts -with_sizes] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_filedebug [dict get $opts -filedebug] ;#per file + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- set ftypes [list f d l] if {"$opt_with_sizes" in {0 1}} { #don't use string is boolean - (f false vs f file!) @@ -705,6 +839,8 @@ namespace eval punk::du { set alltimes [dict create] set links [list] + set linkinfo [dict create] + set debuginfo [dict create] set flaggedhidden [list] set flaggedsystem [list] set flaggedreadonly [list] @@ -717,25 +853,18 @@ namespace eval punk::du { continue } set tail_altname [dict get $iteminfo altname] ;#altname of tail - not whole path - set attrinfo [decode_win_attributes [dict get $iteminfo attrs]] - #puts stderr "$iteminfo" - #puts stderr "$nm -> [dict get $iteminfo attrs] -> $attrinfo" + #set attrinfo [decode_win_attributes [dict get $iteminfo attrs]] set ftype "" #attributes applicable to any classification set fullname [file_join_one $folderpath $nm] - if {"hidden" in $attrinfo} { - lappend flaggedhidden $fullname - } - if {"system" in $attrinfo} { - lappend flaggedsystem $fullname - } - if {"readonly" in $attrinfo} { - lappend flaggedreadonly $fullname - } + set attrdict [Get_attributes_from_iteminfo -debug $opt_filedebug -debugchannel none $iteminfo] ;#-debugchannel none puts -debug key in the resulting dict + set file_attributes [dict get $attrdict -fileattributes] + set linkdata [dict create] + # ----------------------------------------------------------- #main classification - if {"reparse_point" in $attrinfo} { + if {"reparse_point" in $file_attributes} { #this concept doesn't correspond 1-to-1 with unix links #https://learn.microsoft.com/en-us/windows/win32/fileio/reparse-points #review - and see which if any actually belong in the links key of our return @@ -758,17 +887,27 @@ namespace eval punk::du { #Note also - a shortcut created in explorer with drag and drop to an existant folder is a different animal to a symlink (file with .lnk extension) even though it looks the same in explorer window. # #links are techically files too, whether they point to a file/dir or nothing. - lappend links $fullname set ftype "l" - } elseif {"directory" in $attrinfo} { + dict set linkdata linktype reparse_point + dict set linkdata reparseinfo [dict get $attrdict -reparseinfo] + if {"directory" ni $file_attributes} { + dict set linkdata target_type file + } + } + if {"directory" in $file_attributes} { if {$nm in {. ..}} { continue } - lappend dirs $fullname - set ftype "d" - } else { - + if {"reparse_point" ni $file_attributes} { + lappend dirs $fullname + set ftype "d" + } else { + #other mechanisms can't immediately classify a link as file vs directory - so we don't return this info in the main dirs/files collections + dict set linkdata target_type directory + } + } + if {"reparse_point" ni $file_attributes && "directory" ni $file_attributes} { #review - is anything that isn't a reparse_point or a directory, some sort of 'file' in this context? What about the 'device' attribute? Can that occur in a directory listing of some sort? lappend files $fullname if {"f" in $sized_types} { @@ -776,6 +915,17 @@ namespace eval punk::du { } set ftype "f" } + # ----------------------------------------------------------- + + if {[dict get $attrdict -hidden]} { + lappend flaggedhidden $fullname + } + if {[dict get $attrdict -system]} { + lappend flaggedsystem $fullname + } + if {[dict get $attrdict -readonly]} { + lappend flaggedreadonly $fullname + } if {$ftype in $sized_types} { dict set allsizes $fullname [dict create bytes [dict get $iteminfo size]] } @@ -789,6 +939,12 @@ namespace eval punk::du { m [twapi::large_system_time_to_secs_since_1970 [dict get $iteminfo mtime]]\ ] } + if {[dict size $linkdata]} { + dict set linkinfo $fullname $linkdata + } + if {[dict exists $attrdict -debug]} { + dict set debuginfo $fullname [dict get $attrdict -debug] + } } twapi::find_file_close $iterator set vfsmounts [get_vfsmounts_in_folder $folderpath] @@ -799,7 +955,7 @@ namespace eval punk::du { #also determine whether vfs. file system x is *much* faster than file attributes #whether or not there is a corresponding file/dir add any applicable mountpoints for the containing folder - return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes $filesizes sizes $allsizes times $alltimes flaggedhidden $flaggedhidden flaggedsystem $flaggedsystem flaggedreadonly $flaggedreadonly altname $altname opts $effective_opts errors $errors] + return [list dirs $dirs vfsmounts $vfsmounts links $links linkinfo $linkinfo files $files filesizes $filesizes sizes $allsizes times $alltimes flaggedhidden $flaggedhidden flaggedsystem $flaggedsystem flaggedreadonly $flaggedreadonly altname $altname opts $effective_opts debuginfo $debuginfo errors $errors] } proc get_vfsmounts_in_folder {folderpath} { set vfsmounts [list] @@ -911,55 +1067,65 @@ namespace eval punk::du { #note - with this design, we can't glob for all except dotfiles - this is for cross-platform consistency and efficiency (Review). #dotfiles aren't considered hidden on all platforms #some sort of antiglob is a possible enhancement and more consistent with the view that leading dot should be treated as any other filename character in this context. - if {$opt_glob eq "*"} { - #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' - #set parent [lindex $folders $folderidx] - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] - #set hdirs {} - set dirs [glob -nocomplain -dir $folderpath -types d * .*] - - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] - #set hlinks {} - set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove (?) - #set links [lsort -unique [concat $hlinks $links[unset links]]] - - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] - #set hfiles {} - set files [glob -nocomplain -dir $folderpath -types f * .*] - #set files {} - } else { - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + if {"windows" eq $::tcl_platform(platform)} { + if {$opt_glob eq "*"} { + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #set parent [lindex $folders $folderidx] + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] + set dirs [glob -nocomplain -dir $folderpath -types d * .*] - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove (?) + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] + set files [glob -nocomplain -dir $folderpath -types f * .*] + } else { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } + } else { + set hdirs {} + set hfiles {} + set hlinks {} + if {$opt_glob eq "*"} { + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #set parent [lindex $folders $folderidx] + set dirs [glob -nocomplain -dir $folderpath -types d * .*] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + set files [glob -nocomplain -dir $folderpath -types f * .*] + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } #note struct::set difference produces unordered result #struct::set difference removes duplicates (but not always.. e.g if using tcl impl and 2nd element empty!) - #relying on struct::set to remove dupes is somewhat risky. It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets' + #relying on struct::set to remove dupes is somewhat risky. + #It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets' ie lists without dupes + #for this reason we must use the wrapper punk::lib::struct_set_diff_unique, which will use the well behaved critcl for speed if avail, but fall back to a deduping tcl version #remove links and . .. from directories, remove links from files + #ideally we would like to classify links by whether they point to files vs dirs - but there are enough cross-platform differences that we will have to leave it to the caller to sort out for now. #struct::set will affect order: tcl vs critcl give different ordering! - set files [struct::set difference [concat $hfiles $files[unset files]] $links] - set dirs [struct::set difference [concat $hdirs $dirs[unset dirs]] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - #set links [lsort -unique [concat $links $hlinks]] + set files [punk::lib::struct_set_diff_unique [list {*}$hfiles {*}$files[unset files]] $links] + set dirs [punk::lib::struct_set_diff_unique [list {*}$hdirs {*}$dirs[unset dirs] ] [list {*}$links [file join $folderpath .] [file join $folderpath ..]]] #---- set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] - - if {"windows" eq $::tcl_platform(platform)} { - set flaggedhidden [concat $hdirs $hfiles $hlinks] - } else { - #unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden - #this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden - set flaggedhidden {} - } + set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks] + #unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden + #this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden set vfsmounts [get_vfsmounts_in_folder $folderpath] @@ -967,7 +1133,7 @@ namespace eval punk::du { dict set effective_opts -with_times $timed_types dict set effective_opts -with_sizes $sized_types - return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden $flaggedhidden flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] } #zipfs attributes/behaviour fairly different to tclvfs - keep separate @@ -1068,21 +1234,21 @@ namespace eval punk::du { #if {[punk::mix::base::lib::path_a_above_b $folderpath "//zipfs:/"]} {} - #zipfs files also reported as links by glob - review - should we preserve this in response? + #todo - hidden? not returned in attributes on windows at least. + #zipfs files also reported as links by glob - review - should we preserve this in response? (2024 unable to duplicate) if {$opt_glob eq "*"} { set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs - #set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove - set links [list] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files } else { set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - #set links [glob -nocomplain -dir $folderpath -types l $opt_glob] - set links [list] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } #remove any links from our dirs and files collections - set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - set files [struct::set difference $files[unset files] $links] + #see du_dirlisting_generic re struct::set difference issues + set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..]]] + set files [punk::lib::struct_set_diff_unique $files[unset files] $links] #nested vfs mount.. REVIEW - does anything need special handling? @@ -1145,34 +1311,63 @@ namespace eval punk::du { } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + #at least some vfs on windows seem to support the -hidden attribute + #we are presuming glob will accept the -types hidden option for all vfs - even if it doesn't really apply REVIEW + #The extra globs aren't nice - but hopefully the vfs is reasonably performant (?) set errors [dict create] - if {$opt_glob eq "*"} { - set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs - #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? - set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove - set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + if {"windows" eq $::tcl_platform(platform)} { + if {$opt_glob eq "*"} { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set hfiles [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } } else { - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + #we leave it to the ui on unix to classify dotfiles as hidden + set hdirs {} + set hfiles {} + set hlinks {} + if {$opt_glob eq "*"} { + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } } #remove any links from our dirs and files collections - set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - set files [struct::set difference $files[unset files] $links] + #see du_dirlisting_generic re struct::set difference issues + set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..] ]] + set files [punk::lib::struct_set_diff_unique $files[unset files] $links] #nested vfs mount.. REVIEW - does anything need special handling? set vfsmounts [get_vfsmounts_in_folder $folderpath] set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] + set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks] set effective_opts $opts dict set effective_opts -with_times $timed_types dict set effective_opts -with_sizes $sized_types - return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden $flaggedhidden flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] } #we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files + #but we don't classify as such anyway. (leave for UI) proc du_dirlisting_unix {folderpath args} { set defaults [dict create\ -glob *\ @@ -1224,6 +1419,9 @@ namespace eval punk::du { } #this is not consistent with standard way * works for unix folders - but it is consistent with behaviour of this facility on windows + #we don't classify anything as 'flaggedhidden' on unix. + #it is a convention for dotfiles rather than a flag - and we'll leave the distinction for the display library + #This if {$opt_glob eq "*"} { set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove @@ -1234,8 +1432,9 @@ namespace eval punk::du { set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } #remove any links from our dirs and files collections - set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - set files [struct::set difference $files[unset files] $links] + #see du_dirlisting_generic re struct::set difference issues + set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..] ]] + set files [punk::lib::struct_set_diff_unique $files[unset files] $links] set vfsmounts [get_vfsmounts_in_folder $folderpath] set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] @@ -1251,7 +1450,7 @@ namespace eval punk::du { #return fsizes,allsizes,alltimes metadata in same order as files,dirs,links lists - if specified in sized_types proc du_get_metadata_lists {sized_types timed_types files dirs links} { set meta_dict [dict create] - set meta_types [concat $sized_types $timed_types] + set meta_types [list {*}$sized_types {*}$timed_types] #known tcl stat keys 2023 - review set empty_stat_dict [dict create atime {} ctime {} dev {} gid {} ino {} mode {} mtime {} nlink {} size {} type {} uid {}] #make sure we call file stat only once per item @@ -1264,6 +1463,7 @@ namespace eval punk::du { if {![catch {file stat $path arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] } else { + puts stderr "du_get_metadata_lists: file stat $path error: $errM" dict lappend errors $path "file stat error: $errM" dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] } @@ -1282,6 +1482,9 @@ namespace eval punk::du { if {$ft eq "f"} { #subst with na if empty? lappend fsizes [dict get $pathinfo size] + if {[dict get $pathinfo size] eq ""} { + puts stderr "du_get_metadata_lists: fsize $path is empty!" + } } } if {$ft in $timed_types} { @@ -1291,7 +1494,7 @@ namespace eval punk::du { #todo - fix . The list lengths will presumably match but have empty values if failed to stat if {"f" in $sized_types} { if {[llength $fsizes] ne [llength $files]} { - dict lappend errors $folderpath "failed to retrieve all file sizes" + dict lappend errors general "failed to retrieve all file sizes" } } return [dict create fsizes $fsizes allsizes $allsizes alltimes $alltimes] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm index 7e1ee14c..ca222524 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -9,7 +9,7 @@ # @@ Meta Begin # Application punk::fileline 0.1.0 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::fileline 0 0.1.0] #[copyright "2024"] #[titledesc {file line-handling utilities}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk fileline}] [comment {-- Description at end of page heading --}] +#[moddesc {punk fileline}] [comment {-- Description at end of page heading --}] #[require punk::fileline] #[keywords module text parse file encoding BOM] #[description] @@ -33,7 +33,7 @@ #[para]Utilities for in-memory analysis of text file data as both line data and byte/char-counted data whilst preserving the line-endings (even if mixed) #[para]This is important for certain text files where examining the number of chars/bytes is important #[para]For example - windows .cmd/.bat files need some byte counting to determine if labels lie on chunk boundaries and need to be moved. -#[para]This chunk-size counting will depend on the character encoding. +#[para]This chunk-size counting will depend on the character encoding. #[para]Despite including the word 'file', the library doesn't necessarily deal with reading/writing to the filesystem - #[para]The raw data can be supplied as a string, or loaded from a file using punk::fileline::get_textinfo -file #[subsection Concepts] @@ -42,13 +42,13 @@ # package require punk::fileline # package require fileutil # set rawdata [lb]fileutil::cat data.txt -translation binary[rb] -# punk::fileline::class::textinfo create obj_data $rawdata +# punk::fileline::class::textinfo create obj_data $rawdata # puts stdout [lb]obj_data linecount[rb] #[example_end] #[subsection Notes] #[para]Line records are referred to by a zero-based index instead of a one-based index as is commonly used when displaying files. #[para]This is for programming consistency and convenience, and the module user should do their own conversion to one-based indexing for line display or messaging if desired. -#[para]No support for lone carriage-returns being interpreted as line-endings. +#[para]No support for lone carriage-returns being interpreted as line-endings. #[para]CR line-endings that are intended to be interpreted as such should be mapped to something else before the data is supplied to this module. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -141,7 +141,7 @@ namespace eval punk::fileline::class { variable o_line_epoch variable o_payloadlist variable o_linemap - variable o_LF_C + variable o_LF_C variable o_CRLF_C @@ -158,7 +158,7 @@ namespace eval punk::fileline::class { #[para] Constructor for textinfo object which represents a chunk or all of a file #[para] datachunk should be passed with the file data including line-endings as-is for full functionality. ie use something like: #[example_begin] - # fconfigure $fd -translation binary + # chan configure $fd -translation binary # set chunkdata [lb]read $fd[rb]] #or # set chunkdata [lb]fileutil::cat -translation binary[rb] @@ -191,7 +191,7 @@ namespace eval punk::fileline::class { set o_bom "" ;#review set o_chunk $datachunk - set o_line_epoch [list] + set o_line_epoch [list] set o_chunk_epoch [list "fromchunkchange-at-[clock micros]"] set crlf_lf_placeholders [list \uFFFF \uFFFE] ;#defaults - if already exist in file - error out with message set defaults [dict create\ @@ -206,11 +206,11 @@ namespace eval punk::fileline::class { } } set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set opt_substitutionmap [dict get $opts -substitutionmap] ;#review - can be done by caller - or a loadable -policy set opt_crlf_lf_placeholders [dict get $opts -crlf_lf_placeholders] set opt_userid [dict get $opts -userid] - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- if {[llength $opt_crlf_lf_placeholders] != 2 || [string length [lindex $opt_crlf_lf_placeholders 0]] !=1 || [string length [lindex $opt_crlf_lf_placeholders 1]] !=1} { error "textinfo::constructor error: -crlf_lf_placeholders requires a list of exactly 2 chars" @@ -261,7 +261,7 @@ namespace eval punk::fileline::class { #[call class::textinfo [method chunk] [arg chunkstart] [arg chunkend]] #[para]Return a range of bytes from the underlying raw chunk data. #[para] e.g The following retrieves the entire chunk - #[para] objName chunk 0 end + #[para] objName chunk 0 end return [string range $o_chunk $chunkstart $chunkend] } method chunklen {} { @@ -273,7 +273,7 @@ namespace eval punk::fileline::class { method chunk_boundary_display {chunkstart chunkend chunksize args} { #*** !doctools #[call class::textinfo [method chunk_boundary_display]] - #[para]Returns a string displaying the boundaries at chunksize bytes between chunkstart and chunkend + #[para]Returns a string displaying the boundaries at chunksize bytes between chunkstart and chunkend #[para]Defaults to using ansi colour if punk::ansi module is available. Use -ansi 0 to disable colour set opts [dict create\ -ansi $::punk::fileline::ansi::enabled\ @@ -290,7 +290,6 @@ namespace eval punk::fileline::class { -showconfig 0\ -boundaryheader {Boundary %i% at %b%}\ ] - set known_opts [dict keys $defaults] foreach {k v} $args { switch -- $k { -ansi - -offset - -displaybytes - -truncatedmark - -completemark - -moremark - -continuemark - -linemaxwidth - -linebase - -limit - -boundaries - -showconfig - -boundaryheader { @@ -332,7 +331,7 @@ namespace eval punk::fileline::class { if {$opt_ansi} { set ::punk::fileline::ansi::enabled 1 } else { - set ::punk::fileline::ansi::enabled 0 + set ::punk::fileline::ansi::enabled 0 } if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} { proc ::punk::fileline::a {args} { @@ -351,7 +350,7 @@ namespace eval punk::fileline::class { } proc ::punk::fileline::ansistrip {str} { if {$::punk::fileline::ansi::enabled} { - tailcall ::punk::fileline::ansi::ansistrip $str + tailcall ::punk::fileline::ansi::ansistrip $str } else { return $str } @@ -362,10 +361,10 @@ namespace eval punk::fileline::class { #suport simple end+-int (+-)start(+-)int to set linebase to line corresponding to chunkstart or chunkend #also simple int+int and int-int - nothing more complicated (similar to Tcl lrange etc in that regard) - #commonly this will be something like -start or -end + #commonly this will be something like -start or -end if {![string is integer -strict $opt_linebase]} { set sign "" - set errunrecognised "unrecognised -linebase value '$opt_linebase'. Expected positive or negative integer or -start -start-int -start+int -end -end-int -end+int or -eof (where leading - is optional but probably desirable) " + set errunrecognised "unrecognised -linebase value '$opt_linebase'. Expected positive or negative integer or -start -start-int -start+int -end -end-int -end+int or -eof (where leading - is optional but probably desirable) " if {[string index $opt_linebase 0] eq "-"} { set sign - set tail [string range $opt_linebase 1 end] @@ -403,7 +402,7 @@ namespace eval punk::fileline::class { } else { set linebase $maxline } - set linebase ${sign}$linebase + set linebase ${sign}$linebase } elseif {[string match start* $tail]} { set endmath [string range $tail 5 end] if {[string length $endmath]} { @@ -490,7 +489,7 @@ namespace eval punk::fileline::class { set j [expr {$i+1}] append result [string map [list %b% $b %i% $i %j% $j] $opt_boundaryheader] \n } - set low [expr {max(($b - $pre_bytes),0)}] + set low [expr {max(($b - $pre_bytes),0)}] set high [expr {min(($b + $post_bytes),$max_bytes)}] set lineinfolist [my chunkrange_to_lineinfolist $low $high -show_truncated 1] @@ -504,11 +503,11 @@ namespace eval punk::fileline::class { set e [dict get $lineinfo end] set boundarymarker "" - set displayidx "" + set displayidx "" set linenum_display $linenum if {$s <= $b && $e >= $b} { set idx [expr {$b - $s}] ;#index into whole position in whole line - not so useful if we're viewing a small section of a line - set char [string index [my line $lineidx] $idx] + set char [string index [my line $lineidx] $idx] set char_display [string map [list \r \n ] $char] if {[dict get $lineinfo is_truncated]} { set tside [dict get $lineinfo truncatedside] @@ -528,29 +527,29 @@ namespace eval punk::fileline::class { set linenum_display ${linenum_display},$idx } - set lhs_status $opt_cmark ;#default + set lhs_status $opt_cmark ;#default set rhs_status $opt_cmark ;#default if {[dict get $lineinfo is_truncated]} { set line [dict get $lineinfo truncated] set tside [dict get $lineinfo truncatedside] if {"left" in $tside && "right" in $tside } { - set lhs_status $opt_tmark - set rhs_status $opt_tmark + set lhs_status $opt_tmark + set rhs_status $opt_tmark } elseif {"left" in $tside} { - set lhs_status $opt_tmark + set lhs_status $opt_tmark } elseif {"right" in $tside} { set rhs_status $opt_tmark } } else { - set line [my line $lineidx] + set line [my line $lineidx] } if {$displayidx ne ""} { - set line [string replace $line $displayidx $displayidx [a+ White green bold]$char_display[a]] + set line [string replace $line $displayidx $displayidx [a+ White green bold]$char_display[a]] } - set displayline [string map $le_map $line] - lappend result_list [list $linenum_display $boundarymarker $lhs_status $displayline $rhs_status] + set displayline [string map $le_map $line] + lappend result_list [list $linenum_display $boundarymarker $lhs_status $displayline $rhs_status] } set title_linenum "LNUM" set linenums [lsearch -index 0 -all -inline -subindices $result_list *] @@ -587,12 +586,12 @@ namespace eval punk::fileline::class { method line {lineindex} { #*** !doctools #[call class::textinfo [method line] [arg lineindex]] - #[para]Reconstructs and returns the raw line using the payload and per-line stored line-ending metadata + #[para]Reconstructs and returns the raw line using the payload and per-line stored line-ending metadata #[para]A 'line' may be returned without a line-ending if the unerlying chunk had trailing data without a line-ending (or the chunk was loaded under a non-standard -policy setting) #[para]Whilst such data may not conform to definitions (e.g POSIX) of the terms 'textfile' and 'line' - it is useful here to represent it as a line with metadata le set to "none" #[para]To return just the data which might more commonly be needed for dealing with lines, use the [method linepayload] method - which returns the line data minus line-ending - lassign [my numeric_linerange $lineindex 0] lineindex + lassign [my numeric_linerange $lineindex 0] lineindex set le [dict get $o_linemap $lineindex le] set le_chars [dict get [dict create lf \n crlf \r\n none ""] $le] @@ -642,13 +641,13 @@ namespace eval punk::fileline::class { set opt_strategy [dict get $opts -strategy] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_start [dict get $opts -start] - set opt_start [expr {$opt_start}] + set opt_start [expr {$opt_start}] if {$opt_start != 0} {error "-start unimplemented"} # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_end [dict get $opts -end] set max_line_index [expr {[llength $o_payloadlist]-1}] if {$opt_end eq "end"} { - set opt_end $max_line_index + set opt_end $max_line_index } #TODO if {$opt_end < $max_line_index} {error "-end less than max_line_index unimplemented"} @@ -706,7 +705,7 @@ namespace eval punk::fileline::class { #[para]Line Metadata such as the line-ending for a particular line and the byte/character range it occupies within the chunk can be retrieved with the [method linemeta] method #[para]To retrieve both the line text and metadata in a single call the [method lineinfo] method can be used #[para]To retrieve an entire line including line-ending use the [method line] method. - lassign [my numeric_linerange $lineindex 0] lineindex + lassign [my numeric_linerange $lineindex 0] lineindex return [lindex $o_payloadlist $lineindex] } method linepayloads {startindex endindex} { @@ -723,17 +722,17 @@ namespace eval punk::fileline::class { #[list_begin itemized] #[item] le #[para] A string representing the type of line-ending: crlf|lf|none - #[item] linelen + #[item] linelen #[para] The number of characters/bytes in the whole line including line-ending if any - #[item] payloadlen + #[item] payloadlen #[para] The number of character/bytes in the line excluding line-ending #[item] start - #[para] The zero-based index into the associated raw file data indicating at which byte/character index this line begins + #[para] The zero-based index into the associated raw file data indicating at which byte/character index this line begins #[item] end #[para] The zero-based index into the associated raw file data indicating at which byte/character index this line ends #[para] This end-point corresponds to the last character of the line-ending if any - not necessarily the last character of the line's payload #[list_end] - lassign [my numeric_linerange $lineindex 0] lineindex + lassign [my numeric_linerange $lineindex 0] lineindex dict get $o_linemap $lineindex } method lineinfo {lineindex} { @@ -798,7 +797,7 @@ namespace eval punk::fileline::class { method chunkrange_to_linerange {chunkstart chunkend} { #*** !doctools #[call class::textinfo [method chunkrange_to_linerange] [arg chunkstart] [arg chunkend]] - lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend set linestart -1 for {set i 0} {$i < [llength $o_payloadlist]} {incr i} { @@ -830,7 +829,7 @@ namespace eval punk::fileline::class { #[para]truncation shows the shortened (missing bytes on left and/or right side) part of the entire line (potentially including line-ending or even partial line-ending) #[para]Note that this truncation info is only in the return value of this method - and will not be reflected in [method lineinfo] queries to the main chunk. - lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend set defaults [dict create\ -show_truncated 0\ ] @@ -841,9 +840,9 @@ namespace eval punk::fileline::class { } } set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- set opt_show_truncated [dict get $opts -show_truncated] - # -- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- set infolist [list] set linerange [my chunkrange_to_linerange $chunkstart $chunkend] @@ -879,8 +878,8 @@ namespace eval punk::fileline::class { set truncated [string range $payload_and_le $split end] set lhs [string range $payload_and_le 0 $split-1] - dict set first truncated $truncated - dict set first truncatedleft $lhs + dict set first truncated $truncated + dict set first truncatedleft $lhs } } ########################### @@ -909,7 +908,7 @@ namespace eval punk::fileline::class { if {$chunkend < [dict get $end_info end]} { #there is rhs truncation if {[dict get $first is_truncated]} { - dict set first truncatedside [list left right] + dict set first truncatedside [list left right] } else { dict set first is_truncated 1 dict set first truncatedside [list right] @@ -926,7 +925,7 @@ namespace eval punk::fileline::class { set le_chars [dict get [dict create lf \n crlf \r\n none ""] [dict get $end_info le]] set payload_and_le "${payload}${le_chars}" set split [expr {$chunkend - $line_start}] - set truncated [string range $payload_and_le 0 $split] + set truncated [string range $payload_and_le 0 $split] set rhs [string range $payload_and_le $split+1 end] dict set first truncatedright $rhs if {"left" ni [dict get $first truncatedside]} { @@ -972,13 +971,13 @@ namespace eval punk::fileline::class { set payload_and_le "${payload}${le_chars}" set split [expr {$chunkend - $line_start}] - set truncated [string range $payload_and_le 0 $split] + set truncated [string range $payload_and_le 0 $split] set rhs [string range $payload_and_le $split+1 end] dict set last truncated $truncated dict set last truncatedright $rhs #this has the effect that truncating the rhs by 1 can result in truncated being larger than original payload for crlf lines - as payload now sees the cr - #this is a bit unintuitive - but probably best reflects the reality. The truncated value is the truncated 'line' rather than the truncated 'payload' + #this is a bit unintuitive - but probably best reflects the reality. The truncated value is the truncated 'line' rather than the truncated 'payload' } } @@ -992,7 +991,7 @@ namespace eval punk::fileline::class { ########################### #assertion all records have is_truncated key. #assertion if is_truncated == 1 truncatedside should contain a list of either left, right or both left and right - #assertion If not opt_show_truncated - then truncated records will not have truncated,truncatedleft,truncatedright keys. + #assertion If not opt_show_truncated - then truncated records will not have truncated,truncatedleft,truncatedright keys. return $infolist } @@ -1018,12 +1017,12 @@ namespace eval punk::fileline::class { #Also check if the truncation is directly between an crlf #both an lhs split and an rhs split could land between cr and lf #to be precise - we should presumably count the part within our chunk as either a none for cr or an lf - #This means a caller counting chunk by chunk using this method will sometimes get the wrong answer depending on where crlfs lie relative to their chosen chunk size + #This means a caller counting chunk by chunk using this method will sometimes get the wrong answer depending on where crlfs lie relative to their chosen chunk size #This is presumably ok - as it should be a well known thing to watch out for. #If we're only receiving chunk by chunk we can't reliably detect splits vs lone s in the data #There are surely more efficient ways for a caller to count line-endings in the way that makes sense for them #but we should makes things as easy as possible for users of this line/chunk structure anyway. - + set first [lindex $infolines 0] if {[dict get $first is_truncated]} { #could be the only line - and truncated at one or both ends. @@ -1036,7 +1035,7 @@ namespace eval punk::fileline::class { #if so - then split can only be left side } - + return [dict create lf $lf_count crlf $crlf_count unterminated $none_count warning line_ending_splits_unimplemented] } @@ -1062,13 +1061,13 @@ namespace eval punk::fileline::class { method normalize_indices {startidx endidx max} { #*** !doctools #[call class::textinfo [method normalize_indices] [arg startidx] [arg endidx] [arg max]] - #[para]A utility to convert some of the of Tcl-style list-index expressions such as end, end-1 etc to valid indices in the range 0 to the supplied max - #[para]Basic addition and subtraction expressions such as 4-1 5+2 are accepted + #[para]A utility to convert some of the of Tcl-style list-index expressions such as end, end-1 etc to valid indices in the range 0 to the supplied max + #[para]Basic addition and subtraction expressions such as 4-1 5+2 are accepted #[para]startidx higher than endidx is allowed - #[para]Unlike Tcl's index expressions - we raise an error if the calculated index is out of bounds 0 to max + #[para]Unlike Tcl's index expressions - we raise an error if the calculated index is out of bounds 0 to max set original_startidx $startidx set original_endidx $endidx - set startidx [string map [list _ ""] $startidx] ;#don't barf on Tcl 8.7+ underscores in numbers - we can't just use expr because it will not handle end-x + set startidx [string map [list _ ""] $startidx] ;#don't barf on Tcl 8.7+ underscores in numbers - we can't just use expr because it will not handle end-x set endidx [string map [list _ ""] $endidx] if {![string is digit -strict "$startidx$endidx"]} { foreach whichvar [list start end] { @@ -1079,9 +1078,9 @@ namespace eval punk::fileline::class { set index $max } "*-*" { - #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions + #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions lassign [split $index -] A B - if {$A eq "end"} { + if {$A eq "end"} { set index [expr {$max - $B}] } else { set index [expr {$A - $B}] @@ -1089,7 +1088,7 @@ namespace eval punk::fileline::class { } "*+*" { lassign [split $index +] A B - if {$A eq "end"} { + if {$A eq "end"} { #review - this will just result in out of bounds error in final test - as desired #By calculating here - we will see the result in the error message - but it's probably not particularly useful - as we don't really need end+ support at all. set index [expr {$max + $B}] @@ -1099,9 +1098,9 @@ namespace eval punk::fileline::class { } default { #May be something like +2 or -0 which braced expr can hanle - #we would like to avoid unbraced expr here - as we're potentially dealing with ranges that may come from external sources. + #we would like to avoid unbraced expr here - as we're potentially dealing with ranges that may come from external sources. if {[catch {expr {$index}} index]} { - #could be end+x - but we don't want out of bounds to be valid + #could be end+x - but we don't want out of bounds to be valid #set it to something that the final bounds expr test can deal with set index Inf } @@ -1110,13 +1109,13 @@ namespace eval punk::fileline::class { } } } - #Unlike Tcl lrange,lindex etc - we don't want to support out of bound indices. + #Unlike Tcl lrange,lindex etc - we don't want to support out of bound indices. #show the supplied index and what it was mapped to in the error message. if {$startidx < 0 || $startidx > $max} { - error "Bad start index '$original_startidx'. $startidx out of bounds 0 - $max" + error "Bad start index '$original_startidx'. $startidx out of bounds 0 - $max" } if {$endidx < 0 || $endidx > $max} { - error "Bad end index '$original_endidx'. $endidx out of bounds 0 - $max (try $max or end)" + error "Bad end index '$original_endidx'. $endidx out of bounds 0 - $max (try $max or end)" } return [list $startidx $endidx] } @@ -1137,7 +1136,7 @@ namespace eval punk::fileline::class { set crlf_replace [list \r\n $o_CRLF_C \n $o_LF_C] set normalised_data [string map $crlf_replace $o_chunk] - set lf_lines [split $normalised_data $o_LF_C] + set lf_lines [split $normalised_data $o_LF_C] set idx 0 set lf_count 0 @@ -1146,14 +1145,14 @@ namespace eval punk::fileline::class { set i 0 set imax [expr {[llength $lf_lines]-1}] foreach lfln $lf_lines { - set crlf_parts [split $lfln $o_CRLF_C] + set crlf_parts [split $lfln $o_CRLF_C] if {[llength $crlf_parts] <= 1} { #no crlf set payloadlen [string length $lfln] set le_size 1 set le lf if {$i == $imax} { - #no more lf segments - and no crlfs + #no more lf segments - and no crlfs if {$payloadlen > 0} { #last line in split has chars - therefore there was no trailing line-ending set le_size 0 @@ -1178,7 +1177,7 @@ namespace eval punk::fileline::class { set payloadlen [string length $crlfpart] set linelen [expr {$payloadlen + 2}] dict set o_linemap $idx [list le crlf linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] - incr filedata_offset $linelen + incr filedata_offset $linelen incr crlf_count incr idx } @@ -1201,7 +1200,7 @@ namespace eval punk::fileline::class { set le lf } - lappend o_payloadlist $lfpart + lappend o_payloadlist $lfpart set linelen [expr {$payloadlen + $le_size}] dict set o_linemap $idx [list le $le linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] incr filedata_offset $linelen @@ -1222,8 +1221,11 @@ namespace eval punk::fileline::class { #o_linemap set oldsize [string length $o_chunk] set newchunk "" + #review - what was the intention here? + puts stderr "regenerate_chunk -warning code incomplete" dict for {idx lineinfo} $o_linemap { - set + #??? + #set } @@ -1249,9 +1251,19 @@ namespace eval punk::fileline { #*** !doctools #[subsection {Namespace punk::fileline}] - #[para] Core API functions for punk::fileline + #[para] Core API functions for punk::fileline #[list_begin definitions] + punk::args::define { + @id -id ::punk::fileline::get_textinfo + @cmd -name punk::fileline::get_textinfo -help\ + "return: textinfo object instance" + -file -default {} -type existingfile + -translation -default iso8859-1 + -encoding -default "\uFFFF" + -includebom -default 0 + @values -min 0 -max 1 + } proc get_textinfo {args} { #*** !doctools #[call get_textinfo [opt {option value...}] [opt datachunk]] @@ -1263,18 +1275,11 @@ namespace eval punk::fileline { #[para]If -includebom 1 is specified - the bom will be retained in the stored chunk and the data for line 1, but will undergo the same encoding transformation as the rest of the data #[para]The get_bomid method of the returned object will contain an identifier for any BOM encountered. #[para] e.g utf-8,utf-16be, utf-16le, utf-32be, utf32-le, SCSU, BOCU-1,GB18030, UTF-EBCDIC, utf-1, utf-7 - #[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes of whatever encoding that is. + #[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes of whatever encoding that is. #[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data. #[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes. - set argument_specification { - -file -default {} -type existingfile - -translation -default iso8859-1 - -encoding -default "\uFFFF" - -includebom -default 0 - *values -min 0 -max 1 - } - lassign [dict values [punk::args::get_dict $argument_specification $args]] opts values + lassign [dict values [punk::args::get_by_id ::punk::fileline::get_textinfo $args]] opts values # -- --- --- --- set opt_file [dict get $opts -file] set opt_translation [dict get $opts -translation] @@ -1283,10 +1288,10 @@ namespace eval punk::fileline { # -- --- --- --- if {$opt_file ne ""} { - set filename $opt_file - set fd [open $filename r] - fconfigure $fd -translation binary -encoding $opt_translation;#should use translation binary to get actual line-endings - but we allow caller to override - #Always read encoding in binary - check for bom below and/or apply chosen opt_encoding + set filename $opt_file + set fd [open $filename r] + chan configure $fd -translation binary -encoding $opt_translation;#should use translation binary to get actual line-endings - but we allow caller to override + #Always read encoding in binary - check for bom below and/or apply chosen opt_encoding set rawchunk [read $fd] close $fd if {[llength $values]} { @@ -1333,7 +1338,7 @@ namespace eval punk::fileline { set is_reliabletxt 1 set startdata 4 } elseif {$maybe_bom eq "fffe0000"} { - #Technically ambiguous - could be utf-16le bom followed by utf-16 null character (2 byte null) + #Technically ambiguous - could be utf-16le bom followed by utf-16 null character (2 byte null) puts stderr "WARNING - ambiguous BOM fffe0000 found. Treating as utf-32le - but could be utf-16le - consider manually setting -encoding or converting data to another encoding." set bomid utf-32le set bomenc utf-32le @@ -1358,7 +1363,7 @@ namespace eval punk::fileline { set bomenc "binary" ;# utf-8??? set startdata 3 } elseif {$maybe_bom eq "84319533"} { - if {![dict exists [punk::char::page_names_dict gb18030]]} { + if {![dict exists [punk::char::page_names_dict gb18030] gb18030]} { puts stderr "WARNING - no direct support for GB18030 (chinese) - falling back to cp936/gbk" set bomenc cp936 } else { @@ -1372,7 +1377,7 @@ namespace eval punk::fileline { set bomenc binary set startdata 3 } elseif {[string match "2b2f76*" $maybe_bom]} { - puts stderr "WARNING utf-7 BOM 2b2f76 found - not supported. Falling back to binary and leaving BOM in data!" + puts stderr "WARNING utf-7 BOM 2b2f76 found - not supported. Falling back to binary and leaving BOM in data!" #review - work out how to strip bom - last 2 bits of 4th byte belong to following character set bomid utf-7 set bomenc binary @@ -1431,7 +1436,7 @@ namespace eval punk::fileline { } else { set datachunk [encoding convertfrom $bomenc [string range $rawchunk $startdata end]] set encoding_selected $bomenc - } + } } else { #tcl 8.7 plus has utf-16le etc set datachunk [encoding convertfrom $bomenc [string range $rawchunk $startdata end]] @@ -1441,7 +1446,7 @@ namespace eval punk::fileline { #!? if {$bomenc eq "binary"} { set datachunk [string range $rawchunk $startdata end] - set encoding_selected binary + set encoding_selected binary } else { set datachunk [encoding convertfrom utf-8 [string range $rawchunk $startdata end]] set encoding_selected utf-8 @@ -1483,7 +1488,7 @@ namespace eval punk::fileline { proc file_boundary_display {filename startbyte endbyte chunksize args} { set fd [open $filename r] ;#use default error if file not readable - fconfigure $fd -translation binary + chan configure $fd -translation binary set rawfiledata [read $fd] close $fd set textobj [class::textinfo new $rawfiledata] @@ -1508,7 +1513,7 @@ namespace eval punk::fileline::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::fileline::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] @@ -1530,12 +1535,12 @@ namespace eval punk::fileline::lib { #[para]e.g #[example_begin] # range_spans_chunk_boundaries 10 1750 512 - # is_span 1 boundaries {512 1024 1536} + # is_span 1 boundaries {512 1024 1536} #[example_end] - #[para]The -offset option + #[para]The -offset option #[example_begin] # range_spans_chunk_boundaries 10 1750 512 -offset 2 - # is_span 1 boundaries {514 1026 1538} + # is_span 1 boundaries {514 1026 1538} #[example_end] #[para] This function automatically uses lseq (if Tcl >= 8.7) when number of boundaries spanned is approximately greater than 75 if {[catch {package require Tcl 8.7-}]} { @@ -1557,7 +1562,7 @@ namespace eval punk::fileline::lib { set argd [punk::args::get_dict { -offset -default 0 } $args] - lassign [dict values $argd] opts remainingargs + lassign [dict values $argd] leaders opts remainingargs } @@ -1574,12 +1579,12 @@ namespace eval punk::fileline::lib { namespace eval punk::fileline::system { #*** !doctools #[subsection {Namespace punk::fileline::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API proc wordswap16 {data} { #scan in one endianness - format in the other. Whether we scan le/be first doesn't matter as long as we format using the opposite endianness binary scan $data s* elements ;#scan little endian - return [binary format S* $elements] ;#format big endian + return [binary format S* $elements] ;#format big endian } proc wordswap32 {data} { binary scan $data i* elements @@ -1620,7 +1625,7 @@ namespace eval punk::fileline::system { set start [expr {$start + ($chunksize - $smod)}] if {$start > $end} { return [list is_span 0 boundaries {}] - } + } } set boundaries [lseq $start to $end $chunksize] #offset can be negative @@ -1630,7 +1635,7 @@ namespace eval punk::fileline::system { } else { set overflow 0 } - set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] + set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] if {$overflow} { #we don't know how many overflowed.. set inrange [list] @@ -1666,7 +1671,7 @@ namespace eval punk::fileline::system { set opt_offset [dict get $opts -offset] # -- --- --- --- - set is_span 0 + set is_span 0 set smod [expr {$start % $chunksize}] if {$smod != 0} { set start [expr {$start + ($chunksize - $smod)}] @@ -1679,7 +1684,7 @@ namespace eval punk::fileline::system { set btrack $bstart set boff [expr {$btrack + $opt_offset}] ;#must be growing even if start and offset are negative - as chunksize is at least 1 while {$boff < $start} { - incr btrack $chunksize + incr btrack $chunksize set boff [expr {$btrack + $opt_offset}] } set bstart $btrack @@ -1687,9 +1692,9 @@ namespace eval punk::fileline::system { set bstart $start } for {set b $bstart} {[set boff [expr {$b + $opt_offset}]] <= $end} {incr b $chunksize} { - lappend boundaries $boff - } - + lappend boundaries $boff + } + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries offset $opt_offset] } @@ -1705,7 +1710,7 @@ namespace eval punk::fileline::ansi { #*** !doctools #[subsection {Namespace punk::fileline::ansi}] #[para]These are ansi functions imported from punk::ansi - or no-ops if that package is unavailable - #[para]See [package punk::ansi] for documentation + #[para]See [package punk::ansi] for documentation #[list_begin definitions] variable enabled 1 #*** !doctools @@ -1718,11 +1723,11 @@ namespace eval punk::fileline::ansi { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::fileline [namespace eval punk::fileline { variable pkg punk::fileline 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/punk/lib-0.1.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm index cb786f22..b6c6dd4a 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -10,7 +10,7 @@ # @@ Meta Begin # Application punk::lib 0.1.1 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::lib 0 0.1.1] #[copyright "2024"] #[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk library}] [comment {-- Description at end of page heading --}] +#[moddesc {punk library}] [comment {-- Description at end of page heading --}] #[require punk::lib] #[keywords module utility lib] #[description] -#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. +#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. #[para]The base set includes string and math functions but has no specific theme # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -34,7 +34,7 @@ #[section Overview] #[para] overview of punk::lib #[subsection Concepts] -#[para]The punk::lib modules should have no strong dependencies other than Tcl +#[para]The punk::lib modules should have no strong dependencies other than Tcl #[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. #[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. @@ -48,8 +48,10 @@ #[list_begin itemized] package require Tcl 8.6- +package require punk::args #*** !doctools #[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] # #package require frobz # #*** !doctools @@ -63,38 +65,6 @@ package require Tcl 8.6- #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::lib::class { -# #*** !doctools -# #[subsection {Namespace punk::lib::class}] -# #[para] class definitions -# if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { -# #*** !doctools -# #[list_begin enumerated] -# -# # oo::class create interface_sample1 { -# # #*** !doctools -# # #[enum] CLASS [class interface_sample1] -# # #[list_begin definitions] -# -# # method test {arg1} { -# # #*** !doctools -# # #[call class::interface_sample1 [method test] [arg arg1]] -# # #[para] test method -# # puts "test: $arg1" -# # } -# -# # #*** !doctools -# # #[list_end] [comment {-- end definitions interface_sample1}] -# # } -# -# #*** !doctools -# #[list_end] [comment {--- end class enumeration ---}] -# } -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::lib::ensemble { #wiki.tcl-lang.org/page/ensemble+extend @@ -129,7 +99,7 @@ tcl::namespace::eval punk::lib::ensemble { list [tcl::namespace::which namespace] export *] while 1 { - set renamed ${routinens}::${routinetail}_[info cmdcount] + set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] if {[tcl::namespace::which $renamed] eq {}} break } @@ -138,7 +108,7 @@ tcl::namespace::eval punk::lib::ensemble { tcl::namespace::eval $extension [ list namespace ensemble create -command $routine -unknown [ list apply {{renamed ensemble routine args} { - list $renamed $routine + list $renamed $routine }} $renamed ] ] @@ -147,6 +117,92 @@ tcl::namespace::eval punk::lib::ensemble { } } +# some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated +tcl::namespace::eval punk::lib::check { + proc has_tclbug_script_var {} { + + set script {set j [list spud] ; list} + append script \n + uplevel #0 $script + set rep1 [tcl::unsupported::representation $::j] + set script "" + set rep2 [tcl::unsupported::representation $::j] + + set nostring1 [string match "*no string" $rep1] + set nostring2 [string match "*no string" $rep2] + + #we assume it should have no string rep in either case + #Review: check Tcl versions for behaviour/consistency + if {!$nostring2} { + return true + } else { + return false + } + } + proc has_tclbug_lsearch_strideallinline {} { + #bug only occurs with single -index value combined with -stride -all -inline -subindices + #https://core.tcl-lang.org/tcl/tktview/5a1aaa201d + if {[catch {lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *} result]} { + #we aren't looking for an error result - error most likely indicates tcl too old to support -stride + return 0 + } + return [expr {$result ne "a2"}] + } + + proc has_tclbug_list_quoting_emptyjoin {} { + #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 + set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases + set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" + return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. + } + + proc has_tclbug_safeinterp_compile {{show 0}} { + #ensemble calls within safe interp not compiled + namespace eval [namespace current]::testcompile { + proc ensembletest {} {string index a 0} + } + + set has_bug 0 + + set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] + if {$show} { + puts outer: + puts $bytecode_outer + } + if {![interp issafe]} { + #test of safe subinterp only needed if we aren't already in a safe interp + if {![catch { + interp create x -safe + } errMsg]} { + x eval {proc ensembletest {} {string index a 0}} + set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] + if {$show} { + puts safe: + puts $bytecode_safe + } + interp delete x + #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) + #It's possible the interp we're running in is also not compiling ensembles. + #we could then get a result of 2 - which still indicates a problem + if {[string last "invokeStk" $bytecode_safe] >= 1} { + incr has_bug + } + } else { + #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? + #unlikely - but we should warn + puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" + } + } + + namespace delete [namespace current]::testcompile + + if {[string last "invokeStk" $bytecode_outer] >= 1} { + incr has_bug + } + return $has_bug + } +} + tcl::namespace::eval punk::lib::compat { #*** !doctools #[subsection {Namespace punk::lib::compat}] @@ -157,6 +213,9 @@ tcl::namespace::eval punk::lib::compat { #*** !doctools #[list_begin definitions] + + + if {"::lremove" ne [info commands ::lremove]} { #puts stderr "Warning - no built-in lremove" interp alias {} lremove {} ::punk::lib::compat::lremove @@ -185,7 +244,59 @@ tcl::namespace::eval punk::lib::compat { return [lmap v $keep {lindex $v 1}] } #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. - #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 - and even in 8.7 it doesn't seem to allow returning one index of the stridden 'group' + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 + + if {![info exists ::auto_index(readFile)]} { + if {[info commands ::readFile] eq ""} { + proc ::readFile {filename {mode text}} { + #readFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + + # Read the file + set f [open $filename [dict get {text r binary rb} $mode]] + try { + return [read $f] + } finally { + close $f + } + } + } + } + if {![info exists ::auto_index(writeFile)]} { + if {[info commands ::writeFile] eq ""} { + proc ::writeFile {args} { + #writeFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + switch [llength $args] { + 2 { + lassign $args filename data + set mode text + } + 3 { + lassign $args filename mode data + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + } + default { + set COMMAND [lindex [info level 0] 0] + return -code error -errorcode {TCL WRONGARGS} "wrong # args: should be \"$COMMAND filename ?mode? data\"" + } + } + + # Write the File + set f [open $filename [dict get {text w binary wb} $mode]] + try { + puts -nonewline $f $data + } finally { + close $f + } + } + } + } if {"::lpop" ne [info commands ::lpop]} { #puts stderr "Warning - no built-in lpop" @@ -194,7 +305,7 @@ tcl::namespace::eval punk::lib::compat { proc lpop {lvar args} { #*** !doctools #[call [fun lpop] [arg listvar] [opt {index}]] - #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop + #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop upvar $lvar l if {![llength $args]} { set args [list end] @@ -245,7 +356,7 @@ tcl::namespace::eval punk::lib::compat { append apply_script [string map [list %vname% $vname]\ {upvar 2 %vname% %vname%}\ ] \n - } + } append apply_script $script \n #puts "--> $apply_script" @@ -263,7 +374,7 @@ tcl::namespace::eval punk::lib::compat { if {"::lmap" ne [info commands ::lmap]} { #puts stderr "Warning - no built-in lpop" - interp alias {} lpop {} ::punk::lib::compat::lmaptcl + interp alias {} lmap {} ::punk::lib::compat::lmaptcl } #lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway proc lmaptcl {varnames list script} { @@ -327,23 +438,354 @@ tcl::namespace::eval punk::lib::compat { # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::lib { + variable PUNKARGS tcl::namespace::export * - #variable xyz + variable has_struct_list + set has_struct_list [expr {![catch {package require struct::list}]}] + variable has_struct_set + set has_struct_set [expr {![catch {package require struct::set}]}] + variable has_punk_ansi + set has_punk_ansi [expr {![catch {package require punk::ansi}]}] + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + set has_twapi [expr {![catch {package require twapi}]}] + } + + #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) + proc aliases {{glob *}} { + set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + set ns_mapped [string map {:: \uFFFF} $ns] + #puts stderr "aliases ns: $ns_mapped" + set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: + if {![string length [lindex $segments end]]} { + #special case for :: only include leading segment rather thatn {} {} + set segments [lrange $segments 0 end-1] + } + set segcount [llength $segments] ;#only match number of segments matching current ns + + + set all_aliases [interp aliases {}] + set matched [list] + foreach a $all_aliases { + #normalize with leading :: + if {![string match ::* $a]} { + set abs ::$a + } else { + set abs $a + } + + set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] + set acount [llength $asegs] + #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" + if {($acount - 1) == $segcount} { + if {[lrange $asegs 0 end-1] eq $segments} { + if {[string match $glob [lindex $asegs end]]} { + #report this alias in the current namespace - even though there may be no matching command + lappend matched $a ;#add raw alias token which may or may not have leading :: + } + } + } + } + #set matched_abs [lsearch -all -inline $all_aliases $glob] + + return $matched + } + + proc alias {{aliasorglob ""} args} { + set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + if {[llength $args]} { + if {$aliasorglob in [interp aliases ""]} { + set existing [interp alias "" $aliasorglob] + puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" + } + if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { + #use empty string/whitespace as intention to delete alias + return [interp alias "" $aliasorglob ""] + } + return [interp alias "" $aliasorglob "" {*}$args] + } else { + if {![string length $aliasorglob]} { + set aliaslist [punk::lib::aliases] + puts -nonewline stderr $aliaslist + return + } + #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias + set target [interp alias "" $aliasorglob] + if {[llength $target]} { + return $target + } + + if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { + set aliaslist [punk::lib::aliases $aliasorglob] + puts -nonewline stderr $aliaslist + return + } + return [list] + } + } + + + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + # Maintenance - This is the primary source for tm_version... functions + # - certain packages script require these but without package dependency + # - 1 punk boot script + # - 2 packagetrace module + # - These should be updated to sync with this + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + proc tm_version_isvalid {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionpart $versionpart]]} { + return 1 + } else { + return 0 + } + } + proc tm_version_major {version} { + if {![tm_version_isvalid $version]} { + error "Invalid version '$version' is not a proper Tcl module version number" + } + set firstpart [lindex [split $version .] 0] + #check for a/b in first segment + if {[string is integer -strict $firstpart]} { + return $firstpart + } + if {[string first a $firstpart] > 0} { + return [lindex [split $firstpart a] 0] + } + if {[string first b $firstpart] > 0} { + return [lindex [split $firstpart b] 0] + } + error "tm_version_major unable to determine major version from version number '$version'" + } + proc tm_version_canonical {ver} { + #accepts a single valid version only - not a bounded or unbounded spec + if {![tm_version_isvalid $ver]} { + error "tm_version_canonical version '$ver' is not valid for a package version" + } + set parts [split $ver .] + set newparts [list] + foreach o $parts { + set trimmed [string trimleft $o 0] + set firstnonzero [string index $trimmed 0] + switch -exact -- $firstnonzero { + "" { + lappend newparts 0 + } + a - b { + #e.g 000bnnnn -> bnnnnn + set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] + if {$tailtrimmed eq ""} { + set tailtrimmed 0 + } + lappend newparts 0$firstnonzero$tailtrimmed + } + default { + #digit + if {[string is integer -strict $trimmed]} { + #e.g 0100 -> 100 + lappend newparts $trimmed + } else { + #e.g 0100b003 -> 100b003 (still need to process tail) + if {[set apos [string first a $trimmed]] > 0} { + set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}a${rhs} + } elseif {[set bpos [string first b $trimmed]] > 0} { + set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}b${rhs} + } else { + #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b + error "tm_version_canonical error - trimfail - unexpected" + } + } + } + } + } + return [join $newparts .] + } + proc tm_version_required_canonical {versionspec} { + #also trim leading zero from any dottedpart? + #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. + #e.g 1.01 is equivalent to 1.1 and 01.001 + #also 1b3 == 1b0003 + + if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version + set errmsg "tm_version_required_canonical - invalid version specification" + if {[string first - $versionspec] < 0} { + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form + set from $versionspec + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionpec'" + } + if {![catch {tm_version_major $from} majorv]} { + set from [tm_version_canonical $from] + return "${from}-[expr {$majorv +1}]" + } else { + error "$errmsg '$versionspec'" + } + } else { + # min- or min-max + #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) + set parts [split $versionspec -] ;#we expect only 2 parts + lassign $parts from to + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionspec'" + } + set from [tm_version_canonical $from] + if {[llength $parts] == 2} { + if {$to ne ""} { + if {![tm_version_isvalid $to]} { + error "$errmsg '$versionspec'" + } + set to [tm_version_canonical $to] + return $from-$to + } else { + return $from- + } + } else { + error "$errmsg '$versionspec'" + } + error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" + } + } + # end tm_version... functions + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + + + + # -- --- + #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists + #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 + #8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows + # Review and retest as new versions come out. + # -- --- + proc list_multi_append1 {lvar1 lvar2} { + #clear winner in 2024 + upvar $lvar1 l1 $lvar2 l2 + lappend l1 {*}$l2 + return $l1 + } + proc list_multi_append2 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [list {*}$l1 {*}$l2] + } + proc list_multi_append3 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0] + } + #testing e.g + #set l1_reset {a b c} + #set l2 {a b c d e f g} + #set l1 $l1_reset + #time {list_multi_append1 l1 l2} 1000 + #set l1 $l1_reset + #time {list_multi_append2 l1 l2} 1000 + # -- --- + + + proc lswap {lvar a z} { + upvar $lvar l + if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} { + #lindex_resolve_basic returns only -1 if out of range + #if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred + #(e.g using: lswap mylist end-2 end on a two element list) + + #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report + #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) + set a_index [lindex_resolve $l $a] + set a_msg "" + switch -- $a_index { + -2 { + set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" + } + -3 { + set a_msg "1st supplied index $a is below the lower bound for the list (0)" + } + } + set z_index [lindex_resolve $l $z] + set z_msg "" + switch -- $z_index { + -2 { + set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" + } + -3 { + set z_msg "2nd supplied index $z is below the lower bound for the list (0)" + } + } + set errmsg "lswap cannot swap indices $a and $z" + if {$a_msg ne ""} { + append errmsg \n $a_msg + } + if {$z_msg ne ""} { + append errmsg \n $z_msg + } + error $errmsg + } + set item2 [lindex $l $z] + lset l $z [lindex $l $a] + lset l $a $item2 + return $l + } + #proc lswap2 {lvar a z} { + # upvar $lvar l + # #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + # set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]] + #} + + proc lswap2 {lvar a z} { + upvar $lvar l + #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]] + } + + #an experimental test of swapping vars without intermediate variables + #It's an interesting idea - but probably of little to no practical use + # - the swap_intvars3 version using intermediate var is faster in Tcl + # - This is probably unsurprising - as it's simpler code. + # Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks. + #proc swap_intvars {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}] + #} + #proc swap_intvars2 {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {$_x ^ $_y}] + # set _y [expr {$_x ^ $_y}] + # set _x [expr {$_x ^ $_y}] + #} + #proc swap_intvars3 {swapv1 swapv2} { + # #using intermediate variable + # upvar $swapv1 _x $swapv2 _y + # set z $_x + # set _x $_y + # set _y $z + #} #*** !doctools #[subsection {Namespace punk::lib}] - #[para] Core API functions for punk::lib + #[para] Core API functions for punk::lib #[list_begin definitions] 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 #support minimal set from to proc range {from to} { lseq $from $to } } else { #lseq accepts basic expressions e.g 4-2 for both arguments - #e.g we can do lseq 0 [llength $list]-1 + #e.g we can do lseq 0 [llength $list]-1 #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. proc range {from to} { set to [offset_expr $to] @@ -356,16 +798,16 @@ namespace eval punk::lib { incr from -1 return [lmap v [lrepeat $count 0] {incr from}] } - #slower methods. + #slower methods. #2) - #set i -1 + #set i -1 #set L [lrepeat $count 0] #lmap v $L {lset L [incr i] [incr from];lindex {}} #return $L #3) #set L {} #for {set i 0} {$i < $count} {incr i} { - # lappend L [incr from] + # lappend L [incr from] #} #return $L } elseif {$from > $to} { @@ -379,14 +821,14 @@ namespace eval punk::lib { } #2) - #set i -1 + #set i -1 #set L [lrepeat $count 0] #lmap v $L {lset L [incr i] [incr from -1];lindex {}} #return $L #3) #set L {} #for {set i 0} {$i < $count} {incr i} { - # lappend L [incr from -1] + # lappend L [incr from -1] #} #return $L } else { @@ -395,187 +837,183 @@ namespace eval punk::lib { } } - #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 0] in calling scope ${[lindex [set x] 0]} !} - proc tstr {args} { - set argd [punk::args::get_dict { - *proc -name punk::lib::tstr -help "A rough equivalent of js template literals" - -allowcommands -default 0 -type none -help "if -allowcommands is true placeholder can contain commands e.g {${plaintext1 [lindex $var 0] plaintext2}}" - -return -default list -choices {dict list string} - *values -min 1 -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" - } $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 nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - #set parts [_tstr_split $templatestring] - set parts [_parse_tstr_parts $templatestring] - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - #lappend expressions $expression - lappend params [uplevel 1 [list subst {*}$nocommands $expression]] - - incr idx ;#expression incr - } - switch -- $opt_return { - dict { - return [dict create template $textchunks params $params] - } - list { - return [list $textchunks {*}$params] - } - string { - set out "" - foreach pt $textchunks param $params { - append out $pt $param + proc lzip {args} { + switch -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [lzip2lists {*}$args]} + 3 {return [lzip3lists {*}$args]} + 4 {return [lzip4lists {*}$args]} + 5 {return [lzip5lists {*}$args]} + 6 {return [lzip6lists {*}$args]} + 7 {return [lzip7lists {*}$args]} + 8 {return [lzip8lists {*}$args]} + 9 {return [lzip9lists {*}$args]} + 10 {return [lzip10lists {*}$args]} + 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n } - return $out + return [lzip${n}lists {*}$args] } default { + if {[llength $args] < 4000} { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } else { + return [lzipn {*}$args] + } } } } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::get_dict { - *proc -name 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 {Select * from table where id = ${$id} and etc... ;}] - } - *values -min 2 -max 2 - template -type list -minlen 2 -maxlen 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the Tstr method above does this for you, and also passes in the id automatically" + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + puts "proc punk::lib::lzip${n}lists {$arglist} \{" + puts "$body" + puts "\}" + proc ::punk::lib::lzip${n}lists $arglist $body + } - 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]] ""] - return $result + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} } - proc _parse_tstr_parts {templatestring} { - if {$templatestring eq ""} { - return [list] + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } + + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l } - 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 - set in_placeholder 1 - } else { - append echars $ch - } - } + lmap {*}$lmap_args {lmap v $vars {set $v}} + } + + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + + if {[join $cur {}] eq {}} { + break } - incr i + lappend zip_l $cur } - if {$tchars ne ""} { - lappend parts $tchars + return $zip_l + } + proc lzipn_tcl9a {args} { + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns } - 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 "" + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] } - return $parts + return $outlist } - #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 + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 } - return [lappend list [tcl::string::range $text $start end]] + return $zip_l + } + #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible + if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { + #-stride either not available - or has bug preventing use of main algorithm below + proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + } else { + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] } - #get info about punk nestindex key ie type: list,dict,undetermined - proc nestindex_info {args} { - set argd [punk::args::get_dict { - -parent -default "" - nestindex - } $args] - set opt_parent [dict get $argd opts -parent] - if {$opt_parent eq ""} { - set parent_type undetermined - } else { - set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing - } - - } + namespace import ::punk::args::lib::tstr + proc invoke command { @@ -592,7 +1030,7 @@ namespace eval punk::lib { #}] #see https://wiki.tcl-lang.org/page/open - lassign [chan pipe] chanout chanin + lassign [chan pipe] chanout chanin lappend command 2>@$chanin set fh [open |$command] set stdout [read $fh] @@ -607,61 +1045,65 @@ namespace eval punk::lib { } elseif {$sysmsg eq {CHILDSTATUS}} { return [list $stdout $stderr $exit] } else { - return -options $e $stderr + return -options $e $stderr } } return [list $stdout $stderr 0] } proc pdict {args} { - if {[catch {package require punk::ansi} errM]} { - set sep " = " + package require punk::args + variable has_punk_ansi + if {!$has_punk_ansi} { + set sep " = " } else { #set sep " [a+ Web-seagreen]=[a] " set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " } set argspec [string map [list %sep% $sep] { - *proc -name pdict -help {Print dict keys,values to channel - (see also showdict)} + @id -id ::punk::lib::pdict + @cmd -name pdict -help\ + "Print dict keys,values to channel + The pdict function operates on variable names - passing the value to the showdict function which operates on values + (see also showdict)" - *opts -any 1 + @opts -any 1 #default separator to provide similarity to tcl's parray function -separator -default "%sep%" -roottype -default "dict" -substructure -default {} - -channel -default stdout -help "existing channel - or 'none' to return as string" + -channel -default stdout -help\ + "existing channel - or 'none' to return as string" - *values -min 1 -max -1 + @values -min 1 -max -1 dictvar -type string -help "name of variable. Can be a dict, list or array" patterns -type string -default "*" -multiple 1 -help {Multiple patterns can be specified as separate arguments. - Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash) - The system uses similar patterns to the punk pipeline pattern-matching system. - The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work. - Segments are classified into list,dict and string operations. - Leading % indicates a string operation - e.g %# gives string length - A segment with a single @ is a list operation e.g @0 gives first list element, @1-3 gives the lrange from 1 to 3 - A segment containing 2 @ symbols is a dict operation. e.g @@k1 retrieves the value for dict key 'k1' - The operation type indicator is not always necessary if lower segments in the hierarchy are of the same type as the previous one. - e.g1 pdict env */%# - the pattern starts with default type dict, so * retrieves all keys & values, - the next hierarchy switches to a string operation to get the length of each value. - e.g2 pdict env W* S* - Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns - e.g3 pdict punk_testd */* - This displays 2 levels of the dict hierarchy. - Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all) - - then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator. - e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1 - Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent - The second level segement in each pattern switches to a dict operation to retrieve the value by key. - When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level. - - The pdict function operates on variable names - passing the value to the showdict function which operates on values - } - }] + Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash) + The system uses similar patterns to the punk pipeline pattern-matching system. + The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work. + Segments are classified into list,dict and string operations. + Leading % indicates a string operation - e.g %# gives string length + A segment with a single @ is a list operation e.g @0 gives first list element, @1-3 gives the lrange from 1 to 3 + A segment containing 2 @ symbols is a dict operation. e.g @@k1 retrieves the value for dict key 'k1' + The operation type indicator is not always necessary if lower segments in the hierarchy are of the same type as the previous one. + e.g1 pdict env */%# + the pattern starts with default type dict, so * retrieves all keys & values, + the next hierarchy switches to a string operation to get the length of each value. + e.g2 pdict env W* S* + Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns + e.g3 pdict punk_testd */* + This displays 2 levels of the dict hierarchy. + Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all) + - then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator. + e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1 + Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent + The second level segement in each pattern switches to a dict operation to retrieve the value by key. + When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level. + } + }] #puts stderr "$argspec" set argd [punk::args::get_dict $argspec $args] @@ -691,46 +1133,75 @@ namespace eval punk::lib { # - Copy proc and attempt rework so we can get back to this as a baseline for functionality proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value) #set sep " [a+ Web-seagreen]=[a] " - if {[catch {package require punk::ansi} errM]} { - set sep " = " + variable has_punk_ansi + if {!$has_punk_ansi} { set RST "" + set sep " = " set sep_mismatch " mismatch " } else { - set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " ;#stick to basic default colours for wider terminal support set RST [punk::ansi::a] - set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch[punk::ansi::a] " + set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support + set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST " } - package require punk ;#we need pipeline pattern matching features + package require punk::pipe + #package require punk ;#we need pipeline pattern matching features package require textblock set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { - *id punk::lib::showdict - *proc -name punk::lib::showdict -help "display dictionary keys and values" + @id -id ::punk::lib::showdict + @cmd -name punk::lib::showdict -help "display dictionary keys and values" #todo - table tableobject -return -default "tailtohead" -choices {tailtohead sidebyside} - -channel -default none - -trimright -default 1 -type boolean -help "Trim whitespace off rhs of each line. - This can help prevent a single long line that wraps in terminal from making every line wrap due to long rhs padding - " - -separator -default {%sep%} -help "Separator column between keys and values" - -separator_mismatch -default {%sep_mismatch%} -help "Separator to use when patterns mismatch" - -roottype -default "dict" -help "list,dict,string" - -ansibase_keys -default "" -help "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" + -channel -default none + -trimright -default 1 -type boolean -help\ + "Trim whitespace off rhs of each line. + This can help prevent a single long line that wraps in terminal from making + every line wrap due to long rhs padding." + -separator -default {%sep%} -help\ + "Separator column between keys and values" + -separator_mismatch -default {%sep_mismatch%} -help\ + "Separator to use when patterns mismatch" + -roottype -default "dict" -help\ + "list,dict,string" + -ansibase_keys -default "" -help\ + "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" -substructure -default {} -ansibase_values -default "" - -keytemplates -default {${$key}} -type list -help "list of templates for keys at each level" + -keytemplates -default {\$\{$key\}} -type list -help\ + "list of templates for keys at each level" -keysorttype -default "none" -choices {none dictionary ascii integer real} -keysortdirection -default increasing -choices {increasing decreasing} - *values -min 1 -max -1 - dictvalue -type list -help "dict or list value" - patterns -default "*" -type string -multiple 1 -help "key or key glob pattern" + -debug -default 0 -type boolean -help\ + "When enabled, produces some rudimentary debug output on stderr" + @values -min 1 -max -1 + dictvalue -type list -help\ + "dict or list value" + patterns -default "*" -type string -multiple 1 -help\ + "key or key glob pattern" }] $args] + + #for punk::lib - we want to reduce pkg dependencies. + # - so we won't even use the tcllib debug pkg here + set opt_debug [dict get $argd opts -debug] + if {$opt_debug} { + if {[info body debug::showdict] eq ""} { + proc ::punk::lib::debug::showdict {args} { + catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"} + } + } + } else { + if {[info body debug::showdict] ne ""} { + proc ::punk::lib::debug::showdict {args} {} + } + } + set opt_sep [dict get $argd opts -separator] set opt_mismatch_sep [dict get $argd opts -separator_mismatch] set opt_keysorttype [dict get $argd opts -keysorttype] set opt_keysortdirection [dict get $argd opts -keysortdirection] set opt_trimright [dict get $argd opts -trimright] set opt_keytemplates [dict get $argd opts -keytemplates] + debug::showdict "keytemplates ---> $opt_keytemplates <---" set opt_ansibase_keys [dict get $argd opts -ansibase_keys] set opt_ansibase_values [dict get $argd opts -ansibase_values] set opt_return [dict get $argd opts -return] @@ -751,18 +1222,18 @@ namespace eval punk::lib { set pattern_next_substructure [dict create] set pattern_this_structure [dict create] - # -- --- --- --- + # -- --- --- --- #REVIEW #as much as possible we should pass the indices along as a query to the pipeline pattern matching system so we're not duplicating the work and introducing inconsistencies. #The main difference here is that sometimes we are treating the result as key-val pairs with the key being the query, other times the key is part of the query, or from the result itself (list/dict indices/keys). - #todo - determine if there is a more consistent rule-based way to do this rather than adhoc + #todo - determine if there is a more consistent rule-based way to do this rather than adhoc #e.g pdict something * #we want the keys from the result as individual lines on lhs #e.g pdict something @@ #we want on lhs result on rhs # = v0 #e.g pdict something @0-2,@4 - #we currently return: + #we currently return: #0 = v0 #1 = v1 #2 = v2 @@ -774,7 +1245,7 @@ namespace eval punk::lib { #It may be a matter of documenting what type of indexes are used directly as keys, and which return sets of further keys #The solution for more consistency/predictability may involve being able to bracket some parts of the segment so for example we can apply an @join or %join within a segment #that involves more complex pattern syntax & parsing (to be added to the main pipeline pattern syntax) - # -- --- --- --- + # -- --- --- --- set filtered_keys [list] if {$opt_roottype in {dict list string}} { @@ -789,10 +1260,10 @@ namespace eval punk::lib { set segments [split $pattern_nest /] set levelpatterns [lindex $segments 0] ;#possibly comma separated patterns #we need to use _split_patterns to separate (e.g to protect commas that appear within quotes) - set patterninfo [punk::_split_patterns $levelpatterns] + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] #puts stderr "showdict-->_split_patterns: $patterninfo" foreach v_idx $patterninfo { - lassign $v_idx v idx + lassign $v_idx v idx #we don't support vars on lhs of index in this context - (because we support simplified glob patterns such as x* and literal dict keys such as kv which would otherwise be interpreted as vars with no index) set p $v$idx ;#_split_patterns has split too far in this context - the entire pattern is the index pattern if {[string index $p 0] eq "!"} { @@ -812,31 +1283,31 @@ namespace eval punk::lib { set keys [dict keys $dval] lappend keyset {*}$keys lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } else { lappend keyset %string lappend keyset_structure string - dict set pattern_this_structure $p string + dict set pattern_this_structure $p string } } %# { - dict set pattern_this_structure $p string + dict set pattern_this_structure $p string lappend keyset %# lappend keyset_structure string } # { #todo get_not !# is test for listiness (see punk) - dict set pattern_this_structure $p list + dict set pattern_this_structure $p list lappend keyset # lappend keyset_structure list } ## { - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict lappend keyset [list ## query] - lappend keyset_structure dict + lappend keyset_structure dict } @* { - puts ---->HERE<---- + #puts "showdict ---->@*<----" dict set pattern_this_structure $p list set keys [punk::lib::range 0 [llength $dval]-1] lappend keyset {*}$keys @@ -852,19 +1323,19 @@ namespace eval punk::lib { #returns keys only lappend keyset [list $p query] lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } @*.@* { set keys [dict keys $dval] lappend keyset {*}$keys lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } default { #puts stderr "===p:$p" #the basic scheme also doesn't allow commas in dict keys access via the convenience @@key - which isn't great, especially for arrays where it is common practice! - #we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful - #@@"key,etc" should allow any non-whitespace key + #we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful + #@@"key,etc" should allow any non-whitespace key switch -glob -- $p { {@k\*@*} - {@K\*@*} { #value glob return keys @@ -880,7 +1351,7 @@ namespace eval punk::lib { lappend keyset [list $p query] } lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } @@* { #exact match key - review - should raise error to match punk pipe behaviour? @@ -889,10 +1360,10 @@ namespace eval punk::lib { if {[dict exists $dval $k]} { set keys [dict keys [dict remove $dval $k]] lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] dict] + lappend keyset_structure {*}[lrepeat [llength $keys] dict] } else { lappend keyset {*}[dict keys $dval] - lappend keyset_structure {*}[lrepeat [dict size $dval] dict] + lappend keyset_structure {*}[lrepeat [dict size $dval] dict] } } else { if {[dict exists $dval $k]} { @@ -900,7 +1371,7 @@ namespace eval punk::lib { lappend keyset_structure dict } } - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } @k@* - @K@* { #TODO get_not @@ -909,7 +1380,7 @@ namespace eval punk::lib { lappend keyset $k lappend keyset_structure dict } - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@\*@*} { #return list of values @@ -921,7 +1392,7 @@ namespace eval punk::lib { lappend keyset [list $p query] } lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@\*.@*} { #TODO get_not @@ -929,61 +1400,61 @@ namespace eval punk::lib { set keys [dict keys $dval $k] lappend keyset {*}$keys lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@v\*@*} - {@V\*@*} { #value-glob return value - #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" + #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" if {$get_not} { lappend keyset [list !$p query] } else { lappend keyset [list $p query] } lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@\*v@*} - {@\*V@*} { #key-glob return value lappend keyset [list $p query] lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@\*@*} - {@\*v@*} - {@\*V@} { #key glob return val lappend keyset [list $p query] lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } @??@* { #exact key match - no error lappend keyset [list $p query] lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } default { - set this_type $opt_roottype + set this_type $opt_roottype if {[string match @* $p]} { - #list mode - trim optional list specifier @ + #list mode - trim optional list specifier @ set p [string range $p 1 end] - dict set pattern_this_structure $p list - set this_type list + dict set pattern_this_structure $p list + set this_type list } elseif {[string match %* $p]} { - dict set pattern_this_structure $p string + dict set pattern_this_structure $p string lappend keyset $p - lappend keyset_structure string + lappend keyset_structure string set this_type string } if {$this_type eq "list"} { - dict set pattern_this_structure $p list + dict set pattern_this_structure $p list if {[string is integer -strict $p]} { if {$get_not} { set keys [punk::lib::range 0 [llength $dval]-1] set keys [lremove $keys $p] lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] list] + lappend keyset_structure {*}[lrepeat [llength $keys] list] } else { lappend keyset $p - lappend keyset_structure list + lappend keyset_structure list } } elseif {[string match "?*-?*" $p]} { #could be either - don't change type @@ -996,24 +1467,28 @@ namespace eval punk::lib { } set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds - if {${lower_resolve} == -1} { - #lower bound is above upper list range + if {${lower_resolve} == -2} { + ##x + #lower bound is above upper list range #match with decreasing indices is still possible set lower [expr {[llength $dval]-1}] ;#set to max - } elseif {$lower_resolve == -2} { + } elseif {$lower_resolve == -3} { + ##x set lower 0 } else { set lower $lower_resolve } set upper [punk::lib::lindex_resolve $dval $b] - if {$upper == -2} { + if {$upper == -3} { + ##x #upper bound is below list range - - if {$lower_resolve >=-1} { + if {$lower_resolve >=-2} { + ##x set upper 0 } else { continue } - } elseif {$upper == -1} { + } elseif {$upper == -2} { #use max set upper [expr {[llength $dval]-1}] #assert - upper >=0 because we have ruled out empty lists @@ -1035,15 +1510,15 @@ namespace eval punk::lib { } else { lappend keyset [list @$p query] } - lappend keyset_structure list - } + lappend keyset_structure list + } } elseif {$this_type eq "string"} { - dict set pattern_this_structure $p string + dict set pattern_this_structure $p string } elseif {$this_type eq "dict"} { #default equivalent to @\*@* - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict #puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]" - set keys [dict keys $dval $p] + set keys [dict keys $dval $p] if {$get_not} { set keys [dict keys [dict remove $dval {*}$keys]] } @@ -1058,12 +1533,12 @@ namespace eval punk::lib { } } - # -- --- --- --- + # -- --- --- --- #check next pattern-segment for substructure type to use - # -- --- --- --- + # -- --- --- --- set substructure "" set pnext [lindex $segments 1] - set patterninfo [punk::_split_patterns $levelpatterns] + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] if {[llength $patterninfo] == 0} { # // ? -review - what does this mean? for xpath this would mean at any level set substructure [lindex $pattern_this_structure end] @@ -1081,7 +1556,7 @@ namespace eval punk::lib { set substructure dict } # { - set substructure list + set substructure list } ## { set substructure dict @@ -1104,7 +1579,7 @@ namespace eval punk::lib { if {[string match @* $pnext]} { set substructure list } elseif {[string match %* $pnext]} { - set substructure string + set substructure string } else { #set substructure $opt_roottype #set substructure [dict get $pattern_this_structure $pattern_nest] @@ -1115,13 +1590,13 @@ namespace eval punk::lib { } } } else { - #e.g /@0,%str,.../ + #e.g /@0,%str,.../ #doesn't matter what the individual types are - we have a list result set substructure list } #puts "--pattern_nest: $pattern_nest substructure: $substructure" dict set pattern_next_substructure $pattern_nest $substructure - # -- --- --- --- + # -- --- --- --- if {$opt_keysorttype ne "none"} { set int_keyset 1 @@ -1154,7 +1629,7 @@ namespace eval punk::lib { } #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" } else { - puts stdout "unrecognised roottype: $opt_roottype" + puts stdout "unrecognised roottype: $opt_roottype" return $dval } @@ -1209,7 +1684,7 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - set nextopts [dict get $argd opts] + set nextopts [dict get $argd opts] set subansibasekeys [lrange $opt_ansibase_keys 1 end] @@ -1217,7 +1692,7 @@ namespace eval punk::lib { #dict set nextopts -substructure $nextsub dict set nextopts -keytemplates $nextkeytemplates dict set nextopts -ansibase_keys $subansibasekeys - dict set nextopts -roottype $nextsub + dict set nextopts -roottype $nextsub dict set nextopts -channel none #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" @@ -1249,7 +1724,7 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - set nextopts [dict get $argd opts] + set nextopts [dict get $argd opts] dict set nextopts -roottype $nextsub dict set nextopts -channel none @@ -1276,22 +1751,22 @@ namespace eval punk::lib { set thisval [ansistring VIEWSTYLE -lf 1 $dval] } elseif {[string match *lpad-* $key]} { set hidekey 1 - lassign [split $key -] _ extra + lassign [split $key -] _ extra set width [expr {[textblock::width $dval] + $extra}] set thisval [textblock::pad $dval -which left -width $width] } elseif {[string match *lpadstr-* $key]} { set hidekey 1 - lassign [split $key -] _ extra + lassign [split $key -] _ extra set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] set thisval [textblock::pad $dval -which left -width $width -padchar $extra] } elseif {[string match *rpad-* $key]} { set hidekey 1 - lassign [split $key -] _ extra + lassign [split $key -] _ extra set width [expr {[textblock::width $dval] + $extra}] set thisval [textblock::pad $dval -which right -width $width] } elseif {[string match *rpadstr-* $key]} { set hidekey 1 - lassign [split $key -] _ extra + lassign [split $key -] _ extra set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] set thisval [textblock::pad $dval -which right -width $width -padchar $extra] } else { @@ -1314,14 +1789,14 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - #set nextopts [dict get $argd opts] + #set nextopts [dict get $argd opts] dict set nextopts -roottype $nextsub dict set nextopts -channel none if {[llength $nextpatterns]} { set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] } - + } } if {$this_type eq "string" && $hidekey} { @@ -1363,7 +1838,7 @@ namespace eval punk::lib { } } "sidebyside" { - # TODO - fix + # TODO - fix #This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs. #use ansibase_key etc to make the output more comprehensible in that situation. #This is why it is not the default. (review - terminal width detection and wrapping?) @@ -1405,16 +1880,29 @@ namespace eval punk::lib { } proc is_list_all_in_list {small large} { - package require struct::list - package require struct::set set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]] return [struct::list equal [lsort $small] $small_in_large] } + if {!$has_struct_list || !$has_struct_set} { + set body { + package require struct::list + package require struct::set + } + append body [info body is_list_all_in_list] + proc is_list_all_in_list {small large} $body + } + proc is_list_all_ni_list {a b} { - package require struct::set set i [struct::set intersect $a $b] return [expr {[llength $i] == 0}] } + if {!$has_struct_set} { + set body { + package require struct::list + } + append body [info body is_list_all_ni_list] + proc is_list_all_ni_list {a b} $body + } #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, @@ -1437,12 +1925,24 @@ namespace eval punk::lib { lremove $fromlist {*}$doomed } + #fix for tcl impl of struct::set::diff which doesn't dedupe + proc struct_set_diff_unique {A B} { + package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. + if {[struct::set::Loaded] eq "tcl"} { + return [punk::lib::setdiff $A $B] + } else { + #use (presumably critcl) implementation for speed + return [struct::set difference $A $B] + } + } + + #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B - #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference + #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) #also struct::set difference with critcl is faster proc setdiff {A B} { if {[llength $A] == 0} {return {}} - set d [dict create] + set d [dict create] foreach x $A {dict set d $x {}} foreach x $B {dict unset d $x} return [dict keys $d] @@ -1450,7 +1950,7 @@ namespace eval punk::lib { #bulk dict remove is slower than a foreach with dict unset #proc setdiff2 {fromlist removeitems} { # #if {[llength $fromlist] == 0} {return {}} - # set d [dict create] + # set d [dict create] # foreach x $fromlist { # dict set d $x {} # } @@ -1465,18 +1965,22 @@ namespace eval punk::lib { return [array names tmp] } - package require struct::set - if {[struct::set equal [struct::set union {a a} {}] {a}]} { - proc lunique_unordered {list} { - struct::set union $list {} - } - } else { - puts stderr "WARNING: struct::set union no longer dedupes!" - #we could also test a sequence of: struct::set add - proc lunique_unordered {list} { - tailcall lunique $list + #default/fallback implementation + proc lunique_unordered {list} { + lunique $list + } + if {$has_struct_set} { + if {[struct::set equal [struct::set union {a a} {}] {a}]} { + proc lunique_unordered {list} { + struct::set union $list {} + } + } else { + puts stderr "WARNING: struct::set union no longer dedupes!" + #we could also test a sequence of: struct::set add } } + + #order-preserving proc lunique {list} { set new {} @@ -1522,9 +2026,9 @@ namespace eval punk::lib { } else { #A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set } - } + } return [tcl::dict::create vars $capturevars arrs $capturearrs] - } } [info vars] + } } [info vars] } ] # -- --- --- set cvars [tcl::dict::get $capture vars] @@ -1535,13 +2039,13 @@ namespace eval punk::lib { append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] { array set %realname% [set %arrayalias%][unset %arrayalias%] }] - } - + } + append apply_script [string map [list %script% $script] { #foreach arrayalias [info vars capturedarray_*] { # set realname [string range $arrayalias [string first _ $arrayalias]+1 end] # array set $realname [set $arrayalias][unset arrayalias] - #} + #} #return [eval %script%] %script% }] @@ -1571,7 +2075,7 @@ namespace eval punk::lib { append apply_script [string map [list %vname% $vname]\ {upvar 2 %vname% %vname%}\ ] \n - } + } append apply_script $script \n #puts "--> $apply_script" @@ -1598,28 +2102,42 @@ namespace eval punk::lib { concat {*}[uplevel 1 lmap {*}$args] } - proc dict_getdef {dictValue args} { - if {[llength $args] < 1} { - error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} - } - set keys [lrange $args -1 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] + #proc dict_getdef {dictValue args} { + # if {[llength $args] < 1} { + # error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} + # } + # set keys [lrange $args -1 end-1] + # if {[tcl::dict::exists $dictValue {*}$keys]} { + # return [tcl::dict::get $dictValue {*}$keys] + # } else { + # return [lindex $args end] + # } + #} + 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::lib::dict_getdef "" ::tcl::dict::getdef } + #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" #} #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features @@ -1639,21 +2157,24 @@ namespace eval punk::lib { error "bad expression '$expression': must be integer?\[+-\]integer?" } } - + + # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side proc lindex_resolve {list index} { #*** !doctools #[call [fun lindex_resolve] [arg list] [arg index]] #[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list #[para]Users may define procs which accept a list index and wish to accept the forms understood by Tcl. #[para]This means the proc may be called with something like $x+2 end-$y etc - #[para]Sometimes the actual integer index is desired. + #[para]Sometimes the actual integer index is desired. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]lindex_resolve will parse the index expression and return: - #[para] a) -2 if the supplied index expression is below the lower bound for the supplied list. (< 0) - #[para] b) -1 if the supplied index expression is above the upper bound for the supplied list. (> end) + #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) + #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) + #[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list #[para]Otherwise it will return an integer corresponding to the position in the list. #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway. #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable + #[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2 #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr #if {![llength $list]} { @@ -1662,13 +2183,13 @@ namespace eval punk::lib { #} set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { - #can match +i -i + #can match +i -i if {$index < 0} { - return -2 + return -3 } elseif {$index >= [llength $list]} { - return -1 + return -2 } else { - #integer may still have + sign - normalize with expr + #integer may still have + sign - normalize with expr return [expr {$index}] } } else { @@ -1678,14 +2199,14 @@ namespace eval punk::lib { set offset [string range $index 4 end] if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} if {$op eq "+" && $offset != 0} { - return -1 + return -2 } } else { - #end + #index is 'end' set index [expr {[llength $list]-1}] if {$index < 0} { - #special case - end with empty list - treat end like a positive number out of bounds - return -1 + #special case - 'end' with empty list - treat end like a positive number out of bounds + return -2 } else { return $index } @@ -1693,7 +2214,7 @@ namespace eval punk::lib { if {$offset == 0} { set index [expr {[llength $list]-1}] if {$index < 0} { - return -1 ;#special case + return -2 ;#special case as above } else { return $index } @@ -1702,7 +2223,7 @@ namespace eval punk::lib { set index [expr {([llength $list]-1) - $offset}] } if {$index < 0} { - return -2 + return -3 } else { return $index } @@ -1723,29 +2244,53 @@ namespace eval punk::lib { error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" } if {$index < 0} { - return -2 + return -3 } elseif {$index >= [llength $list]} { - return -1 + return -2 } return $index } } } - proc lindex_resolve2 {list index} { - #set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. + proc lindex_resolve_basic {list index} { + #*** !doctools + #[call [fun lindex_resolve_basic] [arg list] [arg index]] + #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) + #[para] returns -1 for out of range at either end, or a valid integer index + #[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound + #[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command + #[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1 + #[para] For pure integer indices the performance should be equivalent + + #set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ + # - which #for {set i 0} {$i < [llength $list]} {incr i} { # lappend indices $i - #} + #} + set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 + if {[string is integer -strict $index]} { + #can match +i -i + #avoid even the lseq overhead when the index is simple + if {$index < 0 || ($index >= [llength $list])} { + #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. + return -1 + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } if {[llength $list]} { set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. + #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) } else { set indices [list] } set idx [lindex $indices $index] if {$idx eq ""} { + #we have no way to determine if out of bounds is at lower vs upper end return -1 } else { - return $idx + return $idx } } proc lindex_get {list index} { @@ -1763,26 +2308,26 @@ namespace eval punk::lib { proc K {x y} {return $x} #*** !doctools #[call [fun K] [arg x] [arg y]] - #[para]The K-combinator function - returns the first argument, x and discards y + #[para]The K-combinator function - returns the first argument, x and discards y #[para]see [uri https://wiki.tcl-lang.org/page/K] - #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. + #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. proc is_utf8_multibyteprefix {bytes} { #*** !doctools #[call [fun is_utf8_multibyteprefix] [arg str]] #[para] Returns a boolean if str is potentially a prefix for a multibyte utf-8 character - #[para] ie - tests if it is possible that appending more data will result in a utf-8 codepoint + #[para] ie - tests if it is possible that appending more data will result in a utf-8 codepoint #[para] Will return false for an already complete utf-8 codepoint #[para] It is assumed the incomplete sequence is at the beginning of the bytes argument #[para] Suitable input for this might be from the unreturned tail portion of get_utf8_leading $testbytes #[para] e.g using: set head [lb]get_utf8_leading $testbytes[rb] ; set tail [lb]string range $testbytes [lb]string length $head[rb] end[rb] - regexp {(?x) + regexp {(?x) ^ (?: [\xC0-\xDF] | #possible prefix for two-byte codepoint [\xE0-\xEF] [\x80-\xBF]{0,1} | #possible prefix for three-byte codepoint - [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for + [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for ) $ } $bytes @@ -1802,7 +2347,7 @@ namespace eval punk::lib { proc is_utf8_single {1234bytes} { #*** !doctools #[call [fun is_utf8_single] [arg 1234bytes]] - #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) + #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) ^ (?: @@ -1817,7 +2362,7 @@ namespace eval punk::lib { proc get_utf8_leading {rawbytes} { #*** !doctools #[call [fun get_utf8_leading] [arg rawbytes]] - #[para] return the leading portion of rawbytes that is a valid utf8 sequence. + #[para] return the leading portion of rawbytes that is a valid utf8 sequence. #[para] This will stop at the point at which the bytes can't be interpreted as a complete utf-8 codepoint #[para] e.g It will not return the first byte or 2 of a 3-byte utf-8 character if the last byte is missing, and will return only the valid utf-8 string from before the first byte of the incomplete character. #[para] It will also only return the prefix before any bytes that cannot be part of a utf-8 sequence at all. @@ -1832,9 +2377,9 @@ namespace eval punk::lib { [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) ) + } $rawbytes completeChars]} { - return $completeChars - } - return "" + return $completeChars + } + return "" } proc hex2dec {args} { #*** !doctools @@ -1858,19 +2403,19 @@ namespace eval punk::lib { foreach {k v} $argopts { tcl::dict::set opts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v } - # -- --- --- --- + # -- --- --- --- set opt_validate [tcl::dict::get $opts -validate] set opt_empty [tcl::dict::get $opts -empty_as_hex] - # -- --- --- --- + # -- --- --- --- - set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map [list _ ""] [string trim $h]}] + set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map {_ ""} [string trim $h]}] if {$opt_validate} { #Note appended F so that we accept list of empty strings as per the documentation if {![string is xdigit -strict [join $list_largeHex ""]F ]} { error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" } } - if {![string is xdigit -strict [string map [list _ ""] $opt_empty]]} { + if {![string is xdigit -strict [string map {_ ""} $opt_empty]]} { #mapping empty string to a value destroys any advantage of -scanonly #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] @@ -1878,11 +2423,11 @@ namespace eval punk::lib { error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" } } else { - set opt_empty [string trim [string map [list _ ""] $opt_empty]] + set opt_empty [string trim [string map {_ ""} $opt_empty]] if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] set nonempty_head [lrange $list_largeHex 0 $first_empty-1] - set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] } } return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] @@ -1915,7 +2460,7 @@ namespace eval punk::lib { set opt_case [tcl::dict::get $opts -case] set opt_empty [tcl::dict::get $opts -empty_as_decimal] # -- --- --- --- - + set resultlist [list] switch -- [string tolower $opt_case] { @@ -1931,13 +2476,13 @@ namespace eval punk::lib { } set fmt "%${opt_width}.${opt_width}ll${spec}" - set list_decimals [lmap d $list_decimals[unset list_decimals] {string map [list _ ""] [string trim $d]}] - if {![string is digit -strict [string map [list _ ""] $opt_empty]]} { + set list_decimals [lmap d $list_decimals[unset list_decimals] {string map {_ ""} [string trim $d]}] + if {![string is digit -strict [string map {_ ""} $opt_empty]]} { if {[lsearch $list_decimals ""] >=0} { error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" } } else { - set opt_empty [string map [list _ ""] $opt_empty] + set opt_empty [string map {_ ""} $opt_empty] if {[set first_empty [lsearch $list_decimals ""]] >= 0} { set nonempty_head [lrange $list_decimals 0 $first_empty-1] set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] @@ -1959,7 +2504,7 @@ namespace eval punk::lib { #[para]log base b of x #[para]This function uses expr's natural log and the change of base division. #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 - #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 + #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 expr {log($x)/log($b)} } proc factors {x} { @@ -1968,14 +2513,14 @@ namespace eval punk::lib { #[para]Return a sorted list of the positive factors of x where x > 0 #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors - #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions - #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers + #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions + #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers #[para]Comparisons were done with some numbers below 17 digits long - #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. + #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers - #but has the disadvantage of being slower for 'small' numbers and using more memory. + #but has the disadvantage of being slower for 'small' numbers and using more memory. #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x - #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py + #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py #[para] In other mathematical contexts zero may be considered not to divide anything. set factors [list 1] set j 2 @@ -1992,19 +2537,19 @@ namespace eval punk::lib { proc oddFactors {x} { #*** !doctools #[call [fun oddFactors] [arg x]] - #[para]Return a list of odd integer factors of x, sorted in ascending order + #[para]Return a list of odd integer factors of x, sorted in ascending order set j 2 set max [expr {sqrt($x)}] set factors [list 1] while {$j <= $max} { if {$x % $j == 0} { set other [expr {$x / $j}] - if {$other % 2 != 0} { + if {$other % 2} { if {$other ni $factors} { lappend factors $other } } - if {$j % 2 != 0} { + if {$j % 2} { if {$j ni $factors} { lappend factors $j } @@ -2027,7 +2572,7 @@ namespace eval punk::lib { set max [expr {sqrt($x)}] while {$j <= $max} { if {$x % $j == 0} { - return [expr {$x / $j}] + return [expr {$x / $j}] } incr j 2 } @@ -2052,14 +2597,14 @@ namespace eval punk::lib { if {$other % 2 == 0} { set god $j } else { - set god [expr {$x / $j}] + set god [expr {$x / $j}] #lowest j - so other side must be highest break } } incr j 2 } - return $god + return $god } proc greatestOddFactor {x} { #*** !doctools @@ -2115,7 +2660,7 @@ namespace eval punk::lib { #[call [fun commonDivisors] [arg x] [arg y]] #[para]Return a list of all the common factors of x and y #[para](equivalent to factors of their gcd) - return [factors [gcd $x $y]] + return [factors [gcd $x $y]] } #experimental only - there are better/faster ways @@ -2156,8 +2701,8 @@ namespace eval punk::lib { proc hasglobs {str} { #*** !doctools #[call [fun hasglobs] [arg str]] - #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] - #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. + #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] + #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving } @@ -2175,7 +2720,7 @@ namespace eval punk::lib { proc substring_count {str substring} { #*** !doctools #[call [fun substring_count] [arg str] [arg substring]] - #[para]Search str and return number of occurrences of substring + #[para]Search str and return number of occurrences of substring #faster than lsearch on split for str of a few K if {$substring eq ""} {return 0} @@ -2191,7 +2736,7 @@ namespace eval punk::lib { #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values - return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] + return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] } proc askuser {question} { @@ -2199,7 +2744,7 @@ namespace eval punk::lib { #[call [fun askuser] [arg question]] #[para]A basic utility to read an answer from stdin #[para]The prompt is written to the terminal and then it waits for a user to type something - #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. + #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. #[para](Generic terminal raw vs linemode detection not yet present) #[para]The user must hit enter to submit the response @@ -2210,21 +2755,21 @@ namespace eval punk::lib { # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { # puts "Proceeding" # } else { - # puts "Cancelled by user" + # puts "Cancelled by user" # } #[example_end] puts stdout $question flush stdout - set stdin_state [fconfigure stdin] + set stdin_state [chan configure stdin] if {[catch { package require punk::console - set console_raw [set ::punk::console::is_raw] + set console_raw [tsv::get console is_raw] } err_console]} { #assume normal line mode set console_raw 0 } try { - fconfigure stdin -blocking 1 + chan configure stdin -blocking 1 if {$console_raw} { punk::console::disableRaw set answer [gets stdin] @@ -2233,7 +2778,7 @@ namespace eval punk::lib { set answer [gets stdin] } } finally { - fconfigure stdin -blocking [tcl::dict::get $stdin_state -blocking] + chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] } return $answer } @@ -2243,13 +2788,14 @@ namespace eval punk::lib { set result [list] foreach line [split $text \n] { if {[string trim $line] eq ""} { - lappend result "" + lappend result "" } else { lappend result $prefix[string trimright $line] } } return [join $result \n] } + #dedent? proc undent {text} { if {$text eq ""} { return "" @@ -2279,136 +2825,463 @@ namespace eval punk::lib { 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 - } - #test example of the technique - not necessarily particularly useful as a function, except maybe for brevity/clarity. todo - test if inlined version gives any perf advantage compared to a temp var - proc swapnumvars {namea nameb} { - upvar $namea a $nameb b - set a [expr {$a ^ $b}] - set b [expr {$a ^ $b}] - set a [expr {$a ^ $b}] - } + 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 + } + + #e.g linesort -decreasing $data + proc linesort {args} { + #*** !doctools + #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] + #[para]Sort lines in textblock + #[para]Returns another textblock with lines sorted + #[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique + if {[llength $args] < 1} { + error "linesort missing lines argument" + } + set lines [lindex $args end] + set opts [lrange $args 0 end-1] + #.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts + list_as_lines [lsort {*}$opts [linelist $lines]] + } + + proc list_as_lines {args} { + #*** !doctools + #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] + #[para]This simply joines the elements of the list with -joinchar + #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines + #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. + if {[set eop [lsearch $args --]] == [llength $args]-2} { + #end-of-opts not really necessary - except for consistency with lines_as_list + set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]] + } + if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} { + set joinchar [lindex $args 1] + set lines [lindex $args 2] + } elseif {[llength $args] == 1} { + set joinchar "\n" + set lines [lindex $args 0] + } else { + error "list_as_lines usage: list_as_lines ?-joinchar ? " + } + return [join $lines $joinchar] + } + proc list_as_lines2 {args} { + #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? + lassign [tcl::dict::values [punk::args::get_dict { + -joinchar -default \n + @values -min 1 -max 1 + } $args]] leaders opts values + puts "opts:$opts" + puts "values:$values" + return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] + } + + proc lines_as_list {args} { + #*** !doctools + #[call [fun lines_as_list] [opt {option value ...}] [arg text]] + #[para]Returns a list of possibly trimmed lines depeding on options + #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf + #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements + + #The underlying function linelist has the validation code which gives nicer usage errors. + #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error + #..because we don't know what to say if there are odd numbers of args + #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work + #e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway + + if {[lsearch $args "--"] == [llength $args]-2} { + set opts [lrange $args 0 end-2] + } else { + set opts [lrange $args 0 end-1] + } + #set opts [tcl::dict::merge {-block {}} $opts] + set bposn [lsearch $opts -block] + if {$bposn < 0} { + lappend opts -block {} + } + set text [lindex $args end] + #tailcall linelist {*}$opts $text + return [linelist {*}$opts $text] + } + #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds + proc lines_as_list2 {args} { + #pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults + #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc + #we don't have to decide what is an opt vs a value + #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) + lassign [tcl::dict::values [punk::args::get_dict { + @opts -any 1 + -block -default {} + } $args]] leaderdict opts valuedict + tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] + } + + # important for pipeline & match_assign + # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? + # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace + set linelist_body { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + #get_codes_single lists only the codes. no plaintext or empty elements + set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits] == 0} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end] ;#may or may not be SGR + set lastcodeoffset [expr {[string length $lastcode]-1}] + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #code is at tail (no trailing plaintext) + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach code $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } - #e.g linesort -decreasing $data - proc linesort {args} { - #*** !doctools - #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] - #[para]Sort lines in textblock - #[para]Returns another textblock with lines sorted - #[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique - if {[llength $args] < 1} { - error "linesort missing lines argument" + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed } - set lines [lindex $args end] - set opts [lrange $args 0 end-1] - #.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts - list_as_lines [lsort {*}$opts [linelist $lines]] - } - proc list_as_lines {args} { - #*** !doctools - #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] - #[para]This simply joines the elements of the list with -joinchar - #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines - #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. - if {[set eop [lsearch $args --]] == [llength $args]-2} { - #end-of-opts not really necessary - except for consistency with lines_as_list - set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]] - } - if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} { - set joinchar [lindex $args 1] - set lines [lindex $args 2] - } elseif {[llength $args] == 1} { - set joinchar "\n" - set lines [lindex $args 0] - } else { - error "list_as_lines usage: list_as_lines ?-joinchar ? " - } - return [join $lines $joinchar] + return $linelist } - proc list_as_lines2 {args} { - #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? - lassign [tcl::dict::values [punk::args::get_dict { - -joinchar -default \n - *values -min 1 -max 1 - } $args]] opts values - puts "opts:$opts" - puts "values:$values" - return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] } - proc lines_as_list {args} { - #*** !doctools - #[call [fun lines_as_list] [opt {option value ...}] [arg text]] - #[para]Returns a list of possibly trimmed lines depeding on options - #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf - #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements - - #The underlying function linelist has the validation code which gives nicer usage errors. - #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error - #..because we don't know what to say if there are odd numbers of args - #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work - #e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway - - if {[lsearch $args "--"] == [llength $args]-2} { - set opts [lrange $args 0 end-2] - } else { - set opts [lrange $args 0 end-1] - } - #set opts [tcl::dict::merge {-block {}} $opts] - set bposn [lsearch $opts -block] - if {$bposn < 0} { - lappend opts -block {} - } - set text [lindex $args end] - tailcall linelist {*}$opts $text - } - #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds - proc lines_as_list2 {args} { - #pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults - #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc - #we don't have to decide what is an opt vs a value - #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) - lassign [tcl::dict::values [punk::args::get_dict { - *opts -any 1 - -block -default {} - } $args]] opts valuedict - tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] - } - - # important for pipeline & match_assign - # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? - # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace - proc linelist {args} { - set usage "linelist ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + set linelist_body_original { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" if {[llength $args] == 0} { - error "linelist missing textchunk argument usage:$usage" + error "linelist missing textchunk argument usage:$usage" } set text [lindex $args end] - set text [string map [list \r\n \n] $text] ;#review - option? + set text [string map {\r\n \n} $text] ;#review - option? set arglist [lrange $args 0 end-1] set opts [tcl::dict::create\ @@ -2417,7 +3290,7 @@ namespace eval punk::lib { -commandprefix ""\ -ansiresets auto\ -ansireplays 0\ - ] + ] foreach {o v} $arglist { switch -- $o { -block - -line - -commandprefix - -ansiresets - -ansireplays { @@ -2441,24 +3314,24 @@ namespace eval punk::lib { } } #normalize certain combos - if {[set posn [lsearch $opt_block trimhead1]] >=0 && "trimhead" in $opt_block} { + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { set opt_block [lreplace $opt_block $posn $posn] } - if {[set posn [lsearch $opt_block trimtail1]] >=0 && "trimtail" in $opt_block} { + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { set opt_block [lreplace $opt_block $posn $posn] } if {"trimall" in $opt_block} { #no other block options make sense in combination with this - set opt_block [list "trimall"] + set opt_block [list "trimall"] } - #TODO + #TODO if {"triminner" in $opt_block } { error "linelist -block triminner not implemented - sorry" } } - + # -- --- --- --- --- --- set opt_line [tcl::dict::get $opts -line] @@ -2516,7 +3389,7 @@ namespace eval punk::lib { } } elseif {$tl_left} { foreach ln $nlsplit { - lappend linelist [string trimleft $ln] + lappend linelist [string trimleft $ln] } } elseif {$tl_right} { foreach ln $nlsplit { @@ -2534,7 +3407,7 @@ namespace eval punk::lib { set last "-" } else { if {$last ne ""} { - lappend linelist "" + lappend linelist "" } set last "" } @@ -2550,11 +3423,11 @@ namespace eval punk::lib { set lastempty -1 foreach ln $linelist { if {[lindex $linelist $idx] ne ""} { - break + break } else { set lastempty $idx } - incr idx + incr idx } if {$lastempty >=0} { set start [expr {$lastempty +1}] @@ -2567,7 +3440,7 @@ namespace eval punk::lib { set i 0 foreach ln $revlinelist { if {$ln ne ""} { - set linelist [lreverse [lrange $revlinelist $i end]] + set linelist [lreverse [lrange $revlinelist $i end]] break } incr i @@ -2591,19 +3464,20 @@ namespace eval punk::lib { } #review - we need to make sure ansiresets don't accumulate/grow on any line - #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop #see if we can find an ST sequence that most terminals will not display for marking sections? if {$opt_ansireplays} { - package require punk::ansi + #package require punk::ansi + if {$opt_ansiresets} { - set RST [punk::ansi::a] + set RST "\x1b\[0m" } else { set RST "" } set replaycodes $RST ;#todo - default? set transformed [list] #shortcircuit common case of no ansi - #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the have backslash escapes due to Tcl list quoting and escaping behaviour. + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) @@ -2616,7 +3490,7 @@ namespace eval punk::lib { } } else { - #INLINE punk::ansi::codetype::is_sgr_reset + #INLINE punk::ansi::codetype::is_sgr_reset #regexp {\x1b\[0*m$} $code set re_is_sgr_reset {\x1b\[0*m$} #INLINE punk::ansi::codetype::is_sgr @@ -2626,35 +3500,35 @@ namespace eval punk::lib { foreach ln $linelist { #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable - set ansisplits [punk::ansi::ta::split_codes_single $ln] + set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. if {[llength $ansisplits]<= 1} { #plaintext only - no ansi codes in line lappend transformed [string cat $replaycodes $ln $RST] #leave replaycodes as is for next line set nextreplay $replaycodes } else { - set tail $RST + set tail $RST set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { if {[lindex $ansisplits end] eq ""} { #last plaintext is empty. So the line is already suffixed with a reset set tail "" - set nextreplay $RST + set nextreplay $RST } else { #trailing text has been reset within line - but no tail reset present #we normalize by putting a tail reset on anyway - set tail $RST - set nextreplay $RST + set tail $RST + set nextreplay $RST } } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { - #No tail reset - and no need to examine whole line to determine stack that is in effect - set tail $RST + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST set nextreplay $lastcode } else { - #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect #last codeset doesn't end in a pure-reset #whether code was at very end or not - add a reset tail - set tail $RST + set tail $RST #determine effective replay for line set codestack [list start] foreach {pt code} $ansisplits { @@ -2666,7 +3540,7 @@ namespace eval punk::lib { if {[punk::ansi::codetype::is_sgr $code]} { #todo - proper test of each code - so we only take latest background/foreground etc. #requires handling codes with varying numbers of parameters. - #basic simplification - remove straight dupes. + #basic simplification - remove straight dupes. set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. set codestack [lremove $codestack {*}$dup_posns] lappend codestack $code @@ -2696,7 +3570,7 @@ namespace eval punk::lib { } } else { set nextreplay $replaycodes - } + } } if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { #no point attaching any replay @@ -2715,19 +3589,28 @@ namespace eval punk::lib { set transformed [list] foreach ln $linelist { lappend transformed [{*}$opt_commandprefix $ln] - } + } set linelist $transformed } return $linelist } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + proc linelist {args} $linelist_body interp alias {} errortime {} punk::lib::errortime proc errortime {script groupsize {iters 2}} { - #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance set i 0 - set times {} + set times {} if {$iters < 2} {set iters 2} for {set i 0} {$i < $iters} {incr i} { @@ -2746,8 +3629,8 @@ namespace eval punk::lib { set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] } - set sigma [expr {int(sqrt($s2))}] - set average [expr int($average)] + set sigma [expr {int(sqrt($s2))}] + set average [expr {int($average)}] return "$average +/- $sigma microseconds per iteration" } @@ -2790,9 +3673,9 @@ namespace eval punk::lib { default { return [list $dec $c] } - } + } + - } @@ -2803,7 +3686,7 @@ namespace eval punk::lib { set data [tcl::unsupported::disassemble proc [lindex $args 0]] } elseif {[llength $args] == 2} { #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. - #not sure if this handles more complex hierarchies or mixins etc. + #not sure if this handles more complex hierarchies or mixins etc. lassign $args obj method if {![info object isa object $obj]} { error "show_jump_tables unable to examine '$args'. $obj is not an oo object" @@ -2818,7 +3701,7 @@ namespace eval punk::lib { set data [tcl::unsupported::disassemble method $obj $method] } } else { - error "show_jump_tables expected a procname or a class/object and method" + error "show_jump_tables expected a procname or a class/object and method" } set result "" set in_jt 0 @@ -2846,95 +3729,257 @@ namespace eval punk::lib { proc temperature_c_to_f {deg_celsius} { return [expr {($deg_celsius * (9/5.0)) + 32}] } - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + proc interp_sync_package_paths {interp} { + if {![interp exists $interp]} { + error "interp_sync_package_paths error. interp '$interp' not found. Create it first with \[interp create $interp\]" + } + interp eval $interp [list set ::auto_path $::auto_path] + interp eval $interp {tcl::tm::remove {*}[tcl::tm::list]} + interp eval $interp [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] + } + proc objclone {obj} { + append obj2 $obj {} + } + proc set_clone {varname obj} { + #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#todo - way to generate 'internal' docs separately? -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::lib::system { - #*** !doctools - #[subsection {Namespace punk::lib::system}] - #[para] Internal functions that are not part of the API - #[list_begin definitions] + proc format_number {numbers_or_commaformattednumbers {delim ""} {groupsize ""}} { + variable has_twapi + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + set localeid [twapi::get_system_default_lcid] + } + } + #when using twapi we currently only get the localeid - not the specific defaults + #when not using twapi, or on non-windows platforms - we don't currently have a mechanism to look up user preferences for this + set default_delim "," + set default_groupsize 3 + + set results [list] + set nums [objclone $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list + foreach inputnum $nums { + set number [objclone $inputnum] + #also handle tcl 8.7+ underscores in numbers + set number [string map [list _ "" , ""] $number] + #normalize e.g 2e4 -> 20000.0 + set number [expr {$number}] + + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + lappend results [twapi::format_number $number $localeid -idigits -1] + continue + } else { + #setting just one of delim or groupsize means we don't get the user's localeid based default for the non-set one + #todo - document it? Find a way to lookup localeid based defaults whenever either is unspecified? + if {$delim eq ""} {set delim $default_delim} + if {$groupsize eq ""} {set groupsize $default_groupsize} + lappend results [twapi::format_number $number 0 -idigits -1 -sthousand $delim -sgrouping $groupsize] + continue + } + } + #todo - get configured user defaults + if {$delim eq ""} { + set delim $default_delim + } + if {$groupsize eq ""} { + set groupsize $default_groupsize + } - proc has_script_var_bug {} { - set script {set j [list spud] ; list} - append script \n - uplevel #0 $script - set rep1 [tcl::unsupported::representation $::j] - set script "" - set rep2 [tcl::unsupported::representation $::j] + lappend results [delimit_number $number $delim $groupsize] + } - set nostring1 [string match "*no string" $rep1] - set nostring2 [string match "*no string" $rep2] + if {[llength $results] == 1} { + #keep intrep as string rather than list + return [lindex $results 0] + } + return $results + } - #we assume it should have no string rep in either case - #Review: check Tcl versions for behaviour/consistency - if {!$nostring2} { - return true + + #from wiki https://wiki.tcl-lang.org/page/Delimiting+Numberse + # Given a number represented as a string, insert delimiters to break it up for + # readability. Normally, the delimiter will be a comma which will be inserted every + # three digits. However, the delimiter and groupsize are optional arguments, + # permitting use in other locales. + # + # The string is assumed to consist of digits, possibly preceded by spaces, + # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* + + proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { + set number [objclone $unformattednumber] + set number [string map {_ ""} $number] + #normalize using expr - e.g 2e4 -> 20000.0 + set number [expr {$number}] + # First, extract right hand part of number, up to and including decimal point + set point [string last "." $number]; + if {$point >= 0} { + set PostDecimal [string range $number $point+1 end]; + set PostDecimalP 1; } else { - return false + set point [expr {[string length $number] + 1}] + set PostDecimal ""; + set PostDecimalP 0; } - } - proc has_safeinterp_compile_bug {{show 0}} { - #ensemble calls within safe interp not compiled - namespace eval [namespace current]::testcompile { - proc ensembletest {} {string index a 0} + + # Now extract any leading spaces. review - regex for whitespace instead of just ascii space? + set ind 0; + while {[string equal [string index $number $ind] \u0020]} { + incr ind; + } + set FirstNonSpace $ind; + set LastSpace [expr {$FirstNonSpace - 1}]; + set LeadingSpaces [string range $number 0 $LastSpace]; + + # Now extract the non-fractional part of the number, omitting leading spaces. + set MainNumber [string range $number $FirstNonSpace $point-1]; + + # Insert commas into the non-fractional part. + set Length [string length $MainNumber]; + set Phase [expr {$Length % $GroupSize}] + set PhaseMinusOne [expr {$Phase -1}]; + set DelimitedMain ""; + + #First we deal with the extra stuff. + if {$Phase > 0} { + append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; + } + set FirstInGroup $Phase; + set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; + while {$LastInGroup < $Length} { + if {$FirstInGroup > 0} { + append DelimitedMain $delim; + } + append DelimitedMain [string range $MainNumber $FirstInGroup $LastInGroup]; + incr FirstInGroup $GroupSize + incr LastInGroup $GroupSize } - set has_bug 0 + # Reassemble the number. + if {$PostDecimalP} { + return [format "%s%s.%s" $LeadingSpaces $DelimitedMain $PostDecimal]; + } else { + return [format "%s%s" $LeadingSpaces $DelimitedMain]; + } + } - set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] - if {$show} { - puts outer: - puts $bytecode_outer + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval punk::lib::flatgrid { + namespace export filler_count rows cols col row block + + #WARNING - requires lseq and 'lsearch -stride' + #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 + #todo - 8.6 fallback? + + proc filler_count {listlen numcolumns} { + #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error + #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense + expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} + } + proc rows {list numcolumns {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set rows [list] + set i 1 + foreach s [lrange $splits 0 end-1] { + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + incr i } - if {![interp issafe]} { - #test of safe subinterp only needed if we aren't already in a safe interp - if {![catch { - interp create x -safe - } errMsg]} { - x eval {proc ensembletest {} {string index a 0}} - set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] - if {$show} { - puts safe: - puts $bytecode_safe - } - interp delete x - #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) - #It's possible the interp we're running in is also not compiling ensembles. - #we could then get a result of 2 - which still indicates a problem - if {[string last "invokeStk" $bytecode_safe] >= 1} { - incr has_bug - } - } else { - #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? - #unlikely - but we should warn - puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" - } + return $rows + } + proc cols {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] } - - namespace delete [namespace current]::testcompile + return $cols + } + proc cols2 {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [col2 $list $numcolumns $colindex $blank] + } + return $cols + } + proc col {list numcolumns colindex {blank NULL}} { + lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * + } + proc col2 {list numcolumns colindex {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set col [list] + foreach s [lrange $splits 0 end-1] { + lappend col [lindex $padded_list $s+$colindex] + } + return $col + } + proc col3 {list numcolumns colindex {blank NULL}} { + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} + } + proc col4 {list numcolumns colindex {blank NULL}} { + #slow + set vars [lrepeat $numcolumns _] + lset vars $colindex v + if {$blank eq ""} { + return [lmap $vars $list {set v}] + } + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} + } - if {[string last "invokeStk" $bytecode_outer] >= 1} { - incr has_bug + proc block {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " } - return $has_bug + textblock::join -- {*}$colblocks + } + proc block2 {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols2 $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks } +} + +tcl::namespace::eval punk::lib::test { + + + +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#todo - way to generate 'internal' docs separately? +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::lib::system { + #*** !doctools + #[subsection {Namespace punk::lib::system}] + #[para] Internal functions that are not part of the API + #[list_begin definitions] + proc mostFactorsBelow {n} { ##*** !doctools #[call [fun mostFactorsBelow] [arg n]] #[para]Find the number below $n which has the greatest number of factors - #[para]This will get slow quickly as n increases (100K = 1s+ 2024) + #[para]This will get slow quickly as n increases (100K = 1s+ 2024) set most 0 set mostcount 0 for {set i 1} {$i < $n} {incr i} { @@ -2947,9 +3992,9 @@ tcl::namespace::eval punk::lib::system { return [list number $most numfactors $mostcount] } proc factorCountBelow_punk {n} { - ##*** !doctools + ##*** !doctools #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]For numbers 1 to n - keep a tally of the total count of factors #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result #[para]and as a rudimentary performance comparison #[para]gets slow quickly! @@ -2960,9 +4005,9 @@ tcl::namespace::eval punk::lib::system { return $tally } proc factorCountBelow_numtheory {n} { - ##*** !doctools + ##*** !doctools #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]For numbers 1 to n - keep a tally of the total count of factors #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result #[para]and as a rudimentary performance comparison #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) @@ -2998,7 +4043,9 @@ tcl::namespace::eval punk::lib::system { return [concat $smallfactors [lreverse $largefactors] $x] } - # incomplte - report which is the innermost bracket/quote etc awaiting completion for a Tcl command + + + # incomplete - report which is the innermost bracket/quote etc awaiting completion for a Tcl command #important - used by punk::repl proc incomplete {partial} { #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. @@ -3027,7 +4074,7 @@ tcl::namespace::eval punk::lib::system { lappend innerpartials "" } else { if {[lindex $waiting end] eq {"}} { - #this quote is endquote + #this quote is endquote set waiting [lrange $waiting 0 end-1] set innerpartials [lrange $innerpartials 0 end-1] } else { @@ -3035,7 +4082,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting {"} lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -3046,7 +4093,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting "\]" lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -3055,7 +4102,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting "\}" lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -3066,13 +4113,13 @@ tcl::namespace::eval punk::lib::system { set waiting [lrange $waiting 0 end-1] set innerpartials [lrange $innerpartials 0 end-1] } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } } } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } set escaped 0 @@ -3148,15 +4195,41 @@ tcl::namespace::eval punk::lib::system { return $incomplete } + #get info about punk nestindex key ie type: list,dict,undetermined + # pdict devel + proc nestindex_info {args} { + set argd [punk::args::get_dict { + -parent -default "" + nestindex + } $args] + set opt_parent [dict get $argd opts -parent] + if {$opt_parent eq ""} { + set parent_type undetermined + } else { + set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing + } + + #??? + + } #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] } + +tcl::namespace::eval punk::lib::debug { + proc showdict {args} {} +} + +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::lib +} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::lib [tcl::namespace::eval punk::lib { variable pkg punk::lib variable version - set version 0.1.1 + set version 0.1.1 }] return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm index 1e90b5ca..a4bc3c70 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -4,6 +4,7 @@ package provide punk::mix::base [namespace eval punk::mix::base { }] package require punk::path +package require punk::lib ;#format_number etc #base internal plumbing functions namespace eval punk::mix::base { @@ -17,7 +18,7 @@ namespace eval punk::mix::base { set extension "" } #--------- - + uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] } proc _cli {args} { @@ -35,12 +36,14 @@ namespace eval punk::mix::base { } #puts stderr "punk::mix::base extension: [string trimleft $extension :]" if {![string length $extension]} { - #if still no extension - must have been called dirctly as punk::mix::base::_cli + #if still no extension - must have been called directly as punk::mix::base::_cli if {![llength $args]} { set args "help" } set extension [namespace current] } + #init usually used to load commandsets (and export their names) into the extension namespace/ensemble + ${extension}::_init if {![llength $args]} { if {[info exists ${extension}::default_command]} { tailcall $extension [set ${extension}::default_command] @@ -66,7 +69,7 @@ namespace eval punk::mix::base { } #puts stderr "arglen:[llength $args]" #puts stdout "_unknown '$ns' '$args'" - + set d_commands [get_commands -extension $extension] set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] @@ -95,11 +98,11 @@ namespace eval punk::mix::base { } tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns } else { - if {[regexp {.*[*?].*} $subcommand]} { + if {[regexp {.*[*?].*} $subcommand]} { set d_commands [get_commands -extension $from_ns] set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] set matched_commands [lsearch -all -inline $all_commands $subcommand] - set commands "" + set commands "" foreach m $matched_commands { append commands $m \n } @@ -110,12 +113,12 @@ namespace eval punk::mix::base { } proc _split_args {arglist} { #don't assume arglist is fully paired. - set posn [lsearch $arglist -extension] + set posn [lsearch $arglist -extension] set opts [list] if {$posn >= 0} { if {$posn+2 <= [llength $arglist]} { set opts [list -extension [lindex $arglist $posn+1]] - set argsremaining [lreplace $arglist $posn $posn+1] + set argsremaining [lreplace $arglist $posn $posn+1] } else { #no value supplied to -extension error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." @@ -148,7 +151,7 @@ namespace eval punk::mix::base { if {![string length $extension]} { set extension [namespace qualifiers [lindex [info level -1] 0]] } - + set maincommands [list] #extension may still be blank e.g if punk::mix::base::get_commands called directly if {[string length $extension]} { @@ -161,7 +164,7 @@ namespace eval punk::mix::base { } foreach c $nscommands { set cmd [namespace tail $c] - lappend maincommands $cmd + lappend maincommands $cmd } set maincommands [lsort $maincommands] } @@ -187,29 +190,29 @@ namespace eval punk::mix::base { set basecommands [lsort $basecommands] - return [list main $maincommands base $basecommands] + return [list main $maincommands base $basecommands] } proc help {args} { #' **%ensemblecommand% help** *args* - #' + #' #' Help for ensemble commands in the command line interface - #' - #' + #' + #' #' Arguments: - #' + #' #' * args - first word of args is the helptopic requested - usually a command name #' - calling help with no arguments will list available commands - #' + #' #' Returns: help text (text) - #' + #' #' Examples: - #' + #' #' ``` #' %ensemblecommand% help #' ``` - #' - #' - + #' + #' + #extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| # >} inspect -label a {| @@ -217,7 +220,7 @@ namespace eval punk::mix::base { # pipecase ,0/1/#= $switchargs {| # e/0 # >} .=>. {set e} - # pipecase /1,1/1/#= $switchargs + # pipecase /1,1/1/#= $switchargs #} |@@ok/result> " opts $opts] } @@ -605,7 +620,7 @@ namespace eval punk::mix::base { if {$path eq $base} { #attempting to cksum at root/volume level of a filesystem.. extra work - #This needs fixing for general use.. not necessarily just for project repos + #This needs fixing for general use.. not necessarily just for project repos puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" return [list error unsupported_path opts $opts] } @@ -621,7 +636,11 @@ namespace eval punk::mix::base { } md5 { package require md5 - set cksum_command [list md5::md5 -hex -file] + if {[package vsatisfies [package present md5] 2- ] } { + set cksum_command [list md5::md5 -hex -file] + } else { + set cksum_comand [list cksum_md5_file] + } } cksum { package require cksum ;#tcllib @@ -634,7 +653,7 @@ namespace eval punk::mix::base { set cksum_command [list cksum_adler32_file] } sha3 - sha3-256 { - #todo - replace with something that doesn't call another process + #todo - replace with something that doesn't call another process - only if tcllibc not available! #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] set cksum_command [list $sha3_implementation 256] } @@ -652,19 +671,41 @@ namespace eval punk::mix::base { set archivename $tmplocation/[punk::mix::util::tmpfile].tar cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) - - #temp emission to stdout.. todo - repl telemetry channel + + #temp emission to stdout.. todo - repl telemetry channel puts stdout "cksum_path: creating temporary tar archive for $path" - puts stdout " at: $archivename .." - tar::create $archivename $target + puts -nonewline stdout " at: $archivename ..." + set tsstart [clock millis] + if {[set tarpath [auto_execok tar]] ne ""} { + #using an external binary is *significantly* faster than tar::create - but comes with some risks + #review - need to check behaviour/flag variances across platforms + #don't use -z flag. On at least some tar versions the zipped file will contain a timestamped subfolder of filename.tar - which ruins the checksum + #also - tar is generally faster without the compression (although this may vary depending on file size and disk speed?) + exec {*}$tarpath -cf $archivename $target ;#{*} needed in case spaces in tarpath + set tsend [clock millis] + set ms [expr {$tsend - $tsstart}] + puts stdout " tar -cf done ($ms ms)" + } else { + set tsstart [clock millis] ;#don't include auto_exec search time for tar::create + tar::create $archivename $target + set tsend [clock millis] + set ms [expr {$tsend - $tsstart}] + puts stdout " tar::create done ($ms ms)" + puts stdout " NOTE: install tar executable for potentially *much* faster directory checksum processing" + } + if {$ftype eq "file"} { - set sizeinfo "(size [file size $target])" + set sizeinfo "(size [punk::lib::format_number [file size $target]] bytes)" } else { - set sizeinfo "(file type $ftype - size unknown)" + set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)" } - puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." + set tsstart [clock millis] + puts -nonewline stdout "cksum_path: calculating cksum using $opt_cksum_algorithm for $target $sizeinfo ... " set cksum [{*}$cksum_command $archivename] - #puts stdout "cksum_path: cleaning up.. " + set tsend [clock millis] + set ms [expr {$tsend - $tsstart}] + puts stdout " cksum done ($ms ms)" + puts stdout " cksum: $cksum" file delete -force $archivename cd $startdir @@ -677,7 +718,7 @@ namespace eval punk::mix::base { set cksum [{*}$cksum_command $path] } } else { - error "cksum_path unsupported $opts for path type [file type $path]" + error "cksum_path unsupported $opts for path type [file type $path]" } } set result [dict create] @@ -692,7 +733,7 @@ namespace eval punk::mix::base { #base can be empty string in which case paths must be absolute #expect dict_path_cksum to be a dict keyed on relpath where each value is a dictionary with keys cksum and opts # ie subdict for can be created from output of cksum_path (for already known values not requiring filling) - # or cksum "" opts [cksum_default_opts] or cksum "" opts {} (for cksum to be filled using supplied cksum opts if any) + # or cksum "" opts [cksum_default_opts] or cksum "" opts {} (for cksum to be filled using supplied cksum opts if any) proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { if {$base eq ""} { set error_paths [list] @@ -726,6 +767,8 @@ namespace eval punk::mix::base { dict for {path pathinfo} $dict_path_cksum { + puts "fill_relativecksums_from_base_and_relativepathdict-->$path REVIEW" + #review to see if we process same path repeatedly, so could avoid repeated 'file exists $fullpath' below by caching a glob if {![dict exists $pathinfo cksum]} { dict set pathinfo cksum "" } else { @@ -734,7 +777,7 @@ namespace eval punk::mix::base { } } if {$base ne ""} { - set fullpath [file join $base $path] + set fullpath [file join $base $path] } else { set fullpath $path } @@ -779,7 +822,7 @@ namespace eval punk::mix::base { #Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will honour valid-looking prefilled cksum values (ie will pass them through) #base is the presumed location to store the checksum file. The caller should retain (normalize if relative) proc get_relativecksum_from_base {base specifiedpath args} { - if {$base ne ""} { + if {$base ne ""} { #targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it #we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix if {[file pathtype $specifiedpath] eq "relative"} { @@ -805,12 +848,12 @@ namespace eval punk::mix::base { #absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" } - set targetpath $specifiedpath + set targetpath $specifiedpath set storedpath [punk::path::relative $base $specifiedpath] - + } } else { - if {[file type $specifiedpath] eq "relative"} { + if {[file pathtype $specifiedpath] eq "relative"} { #if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage set targetpath [file normalize $specifiedpath] set storedpath $targetpath @@ -822,13 +865,13 @@ namespace eval punk::mix::base { # #NOTE: specifiedpath can be a relative path (to cwd) when base is empty - #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc + #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc #possibly also: base: somewhere targetpath: ../elsewhere/etc # #todo - write tests - if {([llength $args] % 2) != 0} { + if {[llength $args] % 2} { error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " } if {[dict exists $args cksum]} { @@ -840,7 +883,7 @@ namespace eval punk::mix::base { set ckopts [cksum_filter_opts {*}$args] set ckinfo [cksum_path $targetpath {*}$ckopts] - + set keyvals $args ;# REVIEW dict set keyvals cksum [dict get $ckinfo cksum] #dict set keyvals cksum_all_opts [dict get $ckinfo opts] @@ -850,7 +893,7 @@ namespace eval punk::mix::base { } #set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop - #storedpath is relative if possible + #storedpath is relative if possible return [dict create $storedpath $keyvals] } @@ -869,7 +912,8 @@ namespace eval punk::mix::base { dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] } - #buildruntime.exe obsolete.. + #buildruntime.exe obsolete.. + puts stderr "warning obsolete? get_all_vfs_build_cksums 'buildruntime.exe'???" set fullpath_buildruntime $buildfolder/buildruntime.exe set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] @@ -903,7 +947,7 @@ namespace eval punk::mix::base { } proc get_all_build_cksums_stored {path} { set buildfolder [get_build_workdir $path] - + set vfscontainer [file dirname $buildfolder] set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] set dict_cksums [dict create] @@ -922,7 +966,7 @@ namespace eval punk::mix::base { } set vfscontainer [file dirname $vfsfolder] set buildfolder $vfscontainer/_build - set dict_vfs [get_vfs_build_cksums $vfsfolder] + set dict_vfs [get_vfs_build_cksums $vfsfolder] set data "" dict for {path cksum} $dict_vfs { append data "$path $cksum" \n diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 5b1ec6da..a099c9b0 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::mix::cli 0.3.1 +# Application punk::mix::cli 0.3.1 # Meta platform tcl # Meta license # @@ Meta End @@ -19,7 +19,7 @@ ##e.g package require frobz package require punk::repo package require punk::ansi -package require punkcheck ;#checksum and/or timestamp records +package require punkcheck ;#checksum and/or timestamp records @@ -31,47 +31,58 @@ namespace eval punk::mix::cli { namespace eval temp_import { } namespace ensemble create + variable initialised 0 - package require punk::overlay - catch { - punk::overlay::import_commandset module . ::punk::mix::commandset::module - } - punk::overlay::import_commandset debug . ::punk::mix::commandset::debug - punk::overlay::import_commandset repo . ::punk::mix::commandset::repo - punk::overlay::import_commandset lib . ::punk::mix::commandset::loadedlib - - catch { - package require punk::mix::commandset::project - punk::overlay::import_commandset project . ::punk::mix::commandset::project - punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection - } - if {[catch { - package require punk::mix::commandset::layout - punk::overlay::import_commandset project.layout . ::punk::mix::commandset::layout - punk::overlay::import_commandset project.layouts . ::punk::mix::commandset::layout::collection - } errM]} { - puts stderr "error loading punk::mix::commandset::layout" - puts stderr $errM - } - if {[catch { - package require punk::mix::commandset::buildsuite - punk::overlay::import_commandset buildsuite . ::punk::mix::commandset::buildsuite - punk::overlay::import_commandset buildsuites . ::punk::mix::commandset::buildsuite::collection - } errM]} { - puts stderr "error loading punk::mix::commandset::buildsuite" - puts stderr $errM - } - punk::overlay::import_commandset scriptwrap . ::punk::mix::commandset::scriptwrap - if {[catch { - package require punk::mix::commandset::doc - punk::overlay::import_commandset doc . ::punk::mix::commandset::doc - punk::overlay::import_commandset "" "" ::punk::mix::commandset::doc::collection - } errM]} { - puts stderr "error loading punk::mix::commandset::doc" - puts stderr $errM + #lazy _init - called by punk::mix::base::_cli when ensemble used + proc _init {args} { + variable initialised + if {$initialised} { + return + } + puts stderr "punk::mix::cli::init $args" + package require punk::overlay + namespace eval ::punk::mix::cli { + catch { + punk::overlay::import_commandset module . ::punk::mix::commandset::module + } + punk::overlay::import_commandset debug . ::punk::mix::commandset::debug + punk::overlay::import_commandset repo . ::punk::mix::commandset::repo + punk::overlay::import_commandset lib . ::punk::mix::commandset::loadedlib + + catch { + package require punk::mix::commandset::project + punk::overlay::import_commandset project . ::punk::mix::commandset::project + punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + } + if {[catch { + package require punk::mix::commandset::layout + punk::overlay::import_commandset project.layout . ::punk::mix::commandset::layout + punk::overlay::import_commandset project.layouts . ::punk::mix::commandset::layout::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::layout" + puts stderr $errM + } + if {[catch { + package require punk::mix::commandset::buildsuite + punk::overlay::import_commandset buildsuite . ::punk::mix::commandset::buildsuite + punk::overlay::import_commandset buildsuites . ::punk::mix::commandset::buildsuite::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::buildsuite" + puts stderr $errM + } + punk::overlay::import_commandset scriptwrap . ::punk::mix::commandset::scriptwrap + if {[catch { + package require punk::mix::commandset::doc + punk::overlay::import_commandset doc . ::punk::mix::commandset::doc + punk::overlay::import_commandset "" "" ::punk::mix::commandset::doc::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::doc" + puts stderr $errM + } + } + set initialised 1 } - proc help {args} { #set basehelp [punk::mix::base::help -extension [namespace current] {*}$args] set basehelp [punk::mix::base help {*}$args] @@ -80,12 +91,12 @@ namespace eval punk::mix::cli { } proc stat {{workingdir ""} args} { - dict set args -v 0 - punk::mix::cli::lib::get_status $workingdir {*}$args + dict set args -v 0 + punk::mix::cli::lib::get_status $workingdir {*}$args } proc status {{workingdir ""} args} { - dict set args -v 1 - punk::mix::cli::lib::get_status $workingdir {*}$args + dict set args -v 1 + punk::mix::cli::lib::get_status $workingdir {*}$args } @@ -117,13 +128,13 @@ namespace eval punk::mix::cli { set project_base [punk::repo::find_candidate] set sourcefolder $project_base/src puts stderr "WARNING - project not under git or fossil control" - puts stderr "Using base folder $project_base" + puts stderr "Using base folder $project_base" } else { set sourcefolder $startdir } } - #review - why can't we be anywhere in the project? + #review - why can't we be anywhere in the project? #also - if no make.tcl - can we use the running shell's make.tcl ? (after prompting user?) if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { puts stderr "dev make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" @@ -146,7 +157,7 @@ namespace eval punk::mix::cli { if {![string length $project_base]} { puts stderr "WARNING no git or fossil repository detected." - puts stderr "Using base folder $startdir" + puts stderr "Using base folder $startdir" set project_base $startdir } @@ -166,7 +177,8 @@ namespace eval punk::mix::cli { } } } - cd $sourcefolder + #cd $sourcefolder + #use run so that stdout visible as it goes if {![catch {run --timeout=55000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { #todo - notify if exit because of timeout! @@ -174,11 +186,11 @@ namespace eval punk::mix::cli { set exitcode [dict get $exitinfo exitcode] } else { puts stderr "Error unable to determine exitcode. err: $exitinfo" - cd $startdir + #cd $startdir return false } - cd $startdir + #cd $startdir if {$exitcode != 0} { puts stderr "FAILED with exitcode $exitcode" return false @@ -186,7 +198,7 @@ namespace eval punk::mix::cli { puts stdout "OK make finished " return true } - } + } proc Kettle {args} { tailcall lib::kettle_call lib {*}$args @@ -210,11 +222,12 @@ namespace eval punk::mix::cli { proc validate_modulename {modulename args} { set opts [list\ -errorprefix validate_modulename\ + -strict 0\ ] if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} foreach {k v} $args { switch -- $k { - -errorprefix { + -errorprefix - -strict { dict set opts $k $v } default { @@ -223,8 +236,14 @@ namespace eval punk::mix::cli { } } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_errorprefix [dict get $opts -errorprefix] + set opt_errorprefix [dict get $opts -errorprefix] + set opt_strict [dict get $opts -strict] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {$opt_strict} { + if {[regexp {[A-Z]} $modulename]} { + error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" + } + } validate_name_not_empty_or_spaced $modulename -errorprefix $opt_errorprefix set testname [string map {:: {}} $modulename] @@ -239,6 +258,56 @@ namespace eval punk::mix::cli { } return $modulename } + proc confirm_modulename {modulename} { + set finalised 0 + set aborted 0 + while {!$finalised && !$aborted} { + #first validate with -strict 0 to confirm acceptable while ignoring case issues. + #uppercase is generally valid but not recommended - so has separate prompting. + if {[catch {validate_modulename $modulename -strict 0} errM]} { + set msg "Chosen name didn't pass validation\n" + append msg "reason: $errM\n" + append msg "Please retype the modulename. You will be given a further prompt to confirm or abort." + set modulename [util::askuser $msg] + } elseif {[regexp {[A-Z]} $modulename]} { + set msg "module names containing uppercase are not recommended (see tip 590).\n" + append msg "Please retype the module name '$modulename' to proceed.\n" + append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" + append msg "Retype it all in lowercase to use recommended naming" + set answer [util::askuser $msg] + if {[regexp {[A-Z]} $answer]} { + if {$answer eq $modulename} { + #ok - user insists + set finalised 1 + } else { + #user supplied a different uppercase name - don't set finalised so we bug them again to type it two times the same way to proceed + puts stdout "A different uppercase name was supplied - reconfirmation required." + } + set modulename $answer + } else { + #user has resupplied modulename all as lowercase + if {$answer eq [string tolower $modulename]} { + set finalised 1 + } else { + #.. but it doesn't match original - require rerun + } + set modulename $answer + } + } else { + set answer [util::askuser "Proceed with the module name '$modulename'? Y to continue N to abort"] + if {[string tolower $answer] eq "y"} { + set finalised 1 + } else { + set aborted 1 + } + } + } + if {$aborted} { + return [dict create status error reason errmsg] + } else { + return [dict create status ok modulename $modulename] + } + } proc validate_projectname {projectname args} { set defaults [list\ @@ -263,7 +332,7 @@ namespace eval punk::mix::cli { if {[string first "::" $projectname] >= 0} { error "$opt_errorprefix '$projectname' cannot contain namespace separator '::'" } - return $projectname + return $projectname } proc validate_name_not_empty_or_spaced {name args} { set opts [list\ @@ -296,10 +365,10 @@ namespace eval punk::mix::cli { #ignore trailing .tm .TM if present #if version doesn't pass validation - treat it as part of the modulename and return empty version string without error #Up to caller to validate. - proc split_modulename_version {modulename} { - set lastpart [namespace tail $modulename] + proc split_modulename_version {fullmodulename} { + set lastpart [namespace tail $fullmodulename] set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components - if {[string equal -nocase [file extension $modulename] ".tm"]} { + if {[string equal -nocase [file extension $fullmodulename] ".tm"]} { set fileparts [split [file rootname $lastpart] -] } else { set fileparts [split $lastpart -] @@ -312,14 +381,20 @@ namespace eval punk::mix::cli { set namesegment [join $fileparts -] set versionsegment "" } - return [list $namesegment $versionsegment] + set base [namespace qualifiers $fullmodulename] + if {$base ne ""} { + set modulename "${base}::$namesegment" + } else { + set modulename $namesegment + } + return [list $modulename $versionsegment] } proc get_status {{workingdir ""} args} { set result "" if {$workingdir ne ""} { if {[file pathtype $workingdir] ne "absolute"} { - set workingdir [file normalize $workingdir] + set workingdir [file normalize $workingdir] } set active_dir $workingdir } else { @@ -328,21 +403,21 @@ namespace eval punk::mix::cli { set defaults [dict create\ -v 1\ ] - set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- --- --- + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- set opt_v [dict get $opts -v] - # -- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- set repopaths [punk::repo::find_repos [pwd]] set repos [dict get $repopaths repos] if {![llength $repos]} { - append result [dict get $repopaths warnings] + append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] } else { - append result [dict get $repopaths warnings] + append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] lassign [lindex $repos 0] repopath repotypes if {"fossil" in $repotypes} { - #review - multiple process launches to fossil a bit slow on windows.. + #review - multiple process launches to fossil a bit slow on windows.. #could we query global db in one go instead? # set fossil_prog [auto_execok fossil] @@ -369,14 +444,14 @@ namespace eval punk::mix::cli { if {"project" in $repotypes} { #punk project if {![catch {package require textblock; package require patternpunk}]} { - set result [textblock::join -- [>punk . logo] " " $result] + set result [textblock::join -- [>punk . logo] " " $result] append result \n - } - } + } + } set timeline [exec fossil timeline -n 5 -t ci] set timeline [string map {\r\n \n} $timeline] - append result $timeline + append result $timeline if {$opt_v} { set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] append result \n [punk::repo::workingdir_state_summary $repostate] @@ -441,7 +516,7 @@ namespace eval punk::mix::cli { puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" exit 2 } - set srcdirname [file tail $srcdir] + set srcdirname [file tail $srcdir] set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir if {[llength $subdirlist] == 0} { @@ -503,7 +578,7 @@ namespace eval punk::mix::cli { } set fileparts [split [file rootname $modpath] -] #set tmfile_versionsegment [lindex $fileparts end] - lassign [split_modulename_version $modpath] basename tmfile_versionsegment + lassign [split_modulename_version $modpath] basename tmfile_versionsegment if {$tmfile_versionsegment eq ""} { #split_modulename_version version part will be empty if not valid tcl version #last segment doesn't look even slightly versiony - fail. @@ -547,6 +622,8 @@ namespace eval punk::mix::cli { -glob *\ -max_depth 100\ ] + set had_error 0 + # -max_depth -1 for no limit set build_installername pods_in_$current_source_dir set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] @@ -557,8 +634,8 @@ namespace eval punk::mix::cli { set modulefile $buildfolder/$basename-$module_build_version.tm - $build_event targetset_init INSTALL $podtree_copy - $build_event targetset_addsource $current_source_dir/$modpath + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath if {$tmfile_versionsegment eq $magicversion} { $build_event targetset_addsource $versionfile } @@ -590,7 +667,7 @@ namespace eval punk::mix::cli { if {[file exists $tmfile]} { set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm file rename $tmfile $newname - set tmfile $newname + set tmfile $newname } set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd set data [string map [list $magicversion $module_build_version] $data] @@ -600,7 +677,6 @@ namespace eval punk::mix::cli { close $fdout } #delete and regenerate zip and modpod stubbed zip - set had_error 0 set notes [list] if {[catch { file delete $buildfolder/$basename-$module_build_version.zip @@ -618,20 +694,37 @@ namespace eval punk::mix::cli { package require punk::zip set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate) - if 0 { + #zipfs mkzip does exactly what we need anyway in this case + #unfortunately it's not available in all Tclsh versions we might be running.. + if {[llength [info commands zipfs]]} { + #zipfs mkzip (2025) doesn't add entries for folders. + #(Therefore no timestamps) + #zip reading utils generally intuit their existence and display them - but often an editor can't add comments to them + set wd [pwd] + cd $buildfolder + puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" + zipfs mkzip $zipfile #modpod-$basename-$module_build_version + cd $wd + + } else { #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise + #put in an archive-level comment to aid in debugging + #punk punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * - #punk::zip::mkzip stores permissions - (unix style) which confuses zipfs when reading - it misidentifies dirs as files + #punk::zip::mkzip stores permissions - (unix style) - which zipfs mkzip doesn't + #Directory ident in zipfs relies on folders ending with trailing slash - if missing, it misidentifies dirs as files. + #(ie it can't use permissions/attributes alone to determine directory vs file) + #TODO - review punk::zip::mkzip and/or external zip to provide a fallback? + #JMN25 + + #set had_error 1 + #lappend notes "zipfs_unavailable" + #puts stderr "WARNING: zipfs unavailable can't build $modulefile" + } + if {!$had_error && [file exists $zipfile]} { + package require modpod + modpod::lib::make_zip_modpod $zipfile $modulefile } - #zipfs mkzip does exactly what we need anyway in this case - set wd [pwd] - cd $buildfolder - puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" - zipfs mkzip $zipfile #modpod-$basename-$module_build_version - cd $wd - - package require modpod - modpod::lib::make_zip_modpod $zipfile $modulefile if {$had_error} { @@ -646,41 +739,50 @@ namespace eval punk::mix::cli { } } else { - puts -nonewline stderr "." + puts -nonewline stderr "P" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $build_event targetset_end SKIPPED } $build_event destroy - $build_installer destroy - - $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm - $event targetset_addsource $modulefile - if {\ - [llength [dict get [$event targetset_source_changes] changed]]\ - || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ - } { - - $event targetset_started - # -- --- --- --- --- --- - if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} - lappend module_list $modulefile - file copy -force $modulefile $target_module_dir - puts stderr "Copied zip modpod module $modulefile to $target_module_dir" - # -- --- --- --- --- --- - $event targetset_end OK -note "zip modpod" - } else { - puts -nonewline stderr "." - set did_skip 1 - if {$is_interesting} { - puts stderr "$modulefile [$event targetset_source_changes]" + $build_installer destroy + + #JMN - review + if {!$had_error} { + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "FAILED to copy zip modpod module $modulefile to $target_module_dir" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "Copied zip modpod module $modulefile to $target_module_dir" + # -- --- --- --- --- --- + $event targetset_end OK -note "zip modpod" + } + } else { + puts -nonewline stderr "p" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED } - $event targetset_end SKIPPED } } tarjar { #basename may still contain #tarjar- - #to be obsoleted - update modpod to (optionally) use vfs::tar + #to be obsoleted - update modpod to (optionally) use vfs::tar } file { set m $modpath @@ -706,12 +808,12 @@ namespace eval punk::mix::cli { if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { - #rebuild the .tm from the #tarjar + #rebuild the .tm from the #tarjar if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { - + } else { - + } #REVIEW - should be in same structure/depth as $target_module_dir in _build? @@ -722,22 +824,22 @@ namespace eval punk::mix::cli { set tmfile $buildfolder/$basename-$module_build_version.tm file delete -force $buildfolder/#tarjar-$basename-$module_build_version file delete -force $tmfile - - + + file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version # #bsdtar doesn't seem to work.. or I haven't worked out the right options? #exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version package require tar - tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version + tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version if {![file exists $tmfile]} { puts stdout "ERROR: failed to build tarjar file $tmfile" exit 4 } #copy the file? - #set target $target_module_dir/$basename-$module_build_version.tm + #set target $target_module_dir/$basename-$module_build_version.tm #file copy -force $tmfile $target - + lappend module_list $tmfile } else { #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. @@ -749,7 +851,7 @@ namespace eval punk::mix::cli { # #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] - $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm $event targetset_addsource $versionfile $event targetset_addsource $current_source_dir/$m @@ -791,7 +893,7 @@ namespace eval punk::mix::cli { if {$is_interesting} { puts stdout "skipping module $current_source_dir/$m - no change in sources detected" } - puts -nonewline stderr "." + puts -nonewline stderr "m" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $event targetset_end SKIPPED @@ -800,7 +902,7 @@ namespace eval punk::mix::cli { #------------------------------ } - + continue } ##------------------------------ @@ -815,7 +917,7 @@ namespace eval punk::mix::cli { #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] #set changed_list [dict get $changed_unchanged changed] #---------- - $event targetset_init INSTALL $target_module_dir/$m + $event targetset_init INSTALL $target_module_dir/$m $event targetset_addsource $current_source_dir/$m if {\ [llength [dict get [$event targetset_source_changes] changed]]\ @@ -833,7 +935,7 @@ namespace eval punk::mix::cli { #set file_record [punkcheck::installfile_finished_install $basedir $file_record] $event targetset_end OK -note "already versioned module" } else { - puts -nonewline stderr "." + puts -nonewline stderr "f" set did_skip 1 if {$is_interesting} { puts stderr "$current_source_dir/$m [$event targetset_source_changes]" @@ -849,7 +951,8 @@ namespace eval punk::mix::cli { if {$CALLDEPTH >= $max_depth} { set subdirs [list] } else { - set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set targets_existing [glob -nocomplain -dir $target_module_dir -type d -tail {*}$subdirs] } #puts stderr "subdirs: $subdirs" foreach d $subdirs { @@ -863,7 +966,10 @@ namespace eval punk::mix::cli { if {$skipdir} { continue } - if {![file exists $target_module_dir/$d]} { + #if {![file exists $target_module_dir/$d]} { + # file mkdir $target_module_dir/$d + #} + if {$d ni $targets_existing} { file mkdir $target_module_dir/$d } lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\ @@ -879,7 +985,7 @@ namespace eval punk::mix::cli { } if {$CALLDEPTH == 0} { $event destroy - $installer destroy + $installer destroy } return $module_list } @@ -915,7 +1021,7 @@ namespace eval punk::mix::cli { } dict set kettle_reset_args $p $arglist } - } + } } #call kettle_reinit to ensure recipes point to current project @@ -993,14 +1099,14 @@ namespace eval punk::mix::cli { kettle_reinit } } - set first [lindex $args 0] + set first [lindex $args 0] if {[string match @* $first]} { error "deck kettle doesn't support special operations - try calling tclsh kettle directly" } if {$first eq "-f"} { set args [lassign $args __ path] } else { - set path $startdir/build.tcl + set path $startdir/build.tcl } set opts [list] @@ -1021,9 +1127,9 @@ namespace eval punk::mix::cli { } } - #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names + #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names #This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) - #REVIEW - needs to be updated to keep in sync with kettle. + #REVIEW - needs to be updated to keep in sync with kettle. set knownopts [list\ --exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ --ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ @@ -1100,7 +1206,7 @@ namespace eval punk::mix::cli { package require punk::mix::base package require punk::overlay if {[catch { - punk::overlay::custom_from_base [namespace current] ::punk::mix::base + punk::overlay::custom_from_base [namespace current] ::punk::mix::base } errM]} { puts stderr "punk::mix::cli load error: Failed to overlay punk::mix::base $errM" error "punk::mix::cli error: $errM" @@ -1111,9 +1217,9 @@ namespace eval punk::mix::cli { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::cli [namespace eval punk::mix::cli { variable version - set version 0.3.1 + set version 0.3.1 }] return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.tm new file mode 100644 index 00000000..263ccc96 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.tm @@ -0,0 +1,1128 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::cli 0.3 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require punk::repo +package require punk::ansi +package require punkcheck ;#checksum and/or timestamp records + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#review +#deck - rename to dev +namespace eval punk::mix::cli { + namespace eval temp_import { + } + namespace ensemble create + + package require punk::overlay + catch { + punk::overlay::import_commandset module . ::punk::mix::commandset::module + } + punk::overlay::import_commandset debug . ::punk::mix::commandset::debug + punk::overlay::import_commandset repo . ::punk::mix::commandset::repo + punk::overlay::import_commandset lib . ::punk::mix::commandset::loadedlib + + catch { + package require punk::mix::commandset::project + punk::overlay::import_commandset project . ::punk::mix::commandset::project + punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + } + if {[catch { + package require punk::mix::commandset::layout + punk::overlay::import_commandset project.layout . ::punk::mix::commandset::layout + punk::overlay::import_commandset project.layouts . ::punk::mix::commandset::layout::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::layout" + puts stderr $errM + } + if {[catch { + package require punk::mix::commandset::buildsuite + punk::overlay::import_commandset buildsuite . ::punk::mix::commandset::buildsuite + punk::overlay::import_commandset buildsuites . ::punk::mix::commandset::buildsuite::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::buildsuite" + puts stderr $errM + } + punk::overlay::import_commandset scriptwrap . ::punk::mix::commandset::scriptwrap + if {[catch { + package require punk::mix::commandset::doc + punk::overlay::import_commandset doc . ::punk::mix::commandset::doc + punk::overlay::import_commandset "" "" ::punk::mix::commandset::doc::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::doc" + puts stderr $errM + } + + + proc help {args} { + #set basehelp [punk::mix::base::help -extension [namespace current] {*}$args] + set basehelp [punk::mix::base help {*}$args] + #puts stdout "punk::mix help" + return $basehelp + } + + proc stat {{workingdir ""} args} { + dict set args -v 0 + punk::mix::cli::lib::get_status $workingdir {*}$args + } + proc status {{workingdir ""} args} { + dict set args -v 1 + punk::mix::cli::lib::get_status $workingdir {*}$args + } + + + + + + + +} + + +namespace eval punk::mix::cli { + + + #interp alias {} ::punk::mix::cli::project.new {} ::punk::mix::cli::new + + + proc make {args} { + set startdir [pwd] + set project_base "" ;#empty for unknown + if {[punk::repo::is_git $startdir]} { + set project_base [punk::repo::find_git] + set sourcefolder $project_base/src + } elseif {[punk::repo::is_fossil $startdir]} { + set project_base [punk::repo::find_fossil] + set sourcefolder $project_base/src + } else { + if {[punk::repo::is_candidate $startdir]} { + set project_base [punk::repo::find_candidate] + set sourcefolder $project_base/src + puts stderr "WARNING - project not under git or fossil control" + puts stderr "Using base folder $project_base" + } else { + set sourcefolder $startdir + } + } + + #review - why can't we be anywhere in the project? + #also - if no make.tcl - can we use the running shell's make.tcl ? (after prompting user?) + if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { + puts stderr "dev make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" + if {[string length $project_base]} { + if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $project_base/src]} { + puts stderr "Try cd to $project_base/src" + } + } else { + if {[file exists $startdir/Makefile]} { + puts stdout "A Makefile exists at $startdir/Makefile." + if {"windows" eq $::tcl_platform(platform)} { + puts stdout "Try running: msys2 -ucrt64 -here -c \"make build\" or bash -c \"make build\"" + } else { + puts stdout "Try runing: make build" + } + } + } + return false + } + + if {![string length $project_base]} { + puts stderr "WARNING no git or fossil repository detected." + puts stderr "Using base folder $startdir" + set project_base $startdir + } + + set lc_this_exe [string tolower [info nameofexecutable]] + set lc_proj_bin [string tolower $project_base/bin] + set lc_build_bin [string tolower $project_base/src/_build] + + if {"project" in $args} { + set is_own_exe 0 + if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} { + set is_own_exe 1 + puts stderr "WARNING - running make using executable that may be created by the project being built" + set answer [util::askuser "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N"] + if {[string tolower $answer] ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } + } + } + cd $sourcefolder + #use run so that stdout visible as it goes + if {![catch {run --timeout=55000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { + #todo - notify if exit because of timeout! + puts stderr "exitinfo: $exitinfo" + set exitcode [dict get $exitinfo exitcode] + } else { + puts stderr "Error unable to determine exitcode. err: $exitinfo" + cd $startdir + return false + } + + cd $startdir + if {$exitcode != 0} { + puts stderr "FAILED with exitcode $exitcode" + return false + } else { + puts stdout "OK make finished " + return true + } + } + + proc Kettle {args} { + tailcall lib::kettle_call lib {*}$args + } + proc KettleShell {args} { + tailcall lib::kettle_call shell {*}$args + } + + + + namespace eval lib { + namespace path ::punk::mix::util + + + proc module_types {} { + #first in list is default for unspecified -type when creating new module + #return [list plain tarjar zipkit] + return [list plain tarjar zip] + } + + proc validate_modulename {modulename args} { + set opts [list\ + -errorprefix validate_modulename\ + ] + if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} + foreach {k v} $args { + switch -- $k { + -errorprefix { + dict set opts $k $v + } + default { + error "validate_modulename error: unknown option '$k'. known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + + validate_name_not_empty_or_spaced $modulename -errorprefix $opt_errorprefix + set testname [string map {:: {}} $modulename] + if {[string first : $testname] >=0} { + error "$opt_errorprefix '$modulename' can only contain paired colons" + } + set badchars [list - "$" "?" "*"] + foreach bc $badchars { + if {[string first $bc $modulename] >= 0} { + error "$opt_errorprefix '$modulename' can not contain character '$bc'" + } + } + return $modulename + } + + proc validate_projectname {projectname args} { + set defaults [list\ + -errorprefix projectname\ + ] + if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} + set known_opts [dict keys $defaults] + foreach k [dict keys $args] { + if {$k ni $known_opts} { + error "validate_modulename error: unknown option $k. known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + validate_name_not_empty_or_spaced $projectname -errorprefix $opt_errorprefix + set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] + if {$projectname in $reserved_words } { + error "$opt_errorprefix '$projectname' cannot be one of reserved_words: $reserved_words" + } + if {[string first "::" $projectname] >= 0} { + error "$opt_errorprefix '$projectname' cannot contain namespace separator '::'" + } + return $projectname + } + proc validate_name_not_empty_or_spaced {name args} { + set opts [list\ + -errorprefix projectname\ + ] + if {[llength $args] %2 != 0} {error "validate_name_not_empty_or_spaced args must be name-value pairs: received '$args'"} + foreach {k v} $args { + switch -- $k { + -errorprefix { + dict set opts $k $v + } + default { + error "validate_name_not_empty_or_spaced error: unknown option $k. known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {![string length $name]} { + error "$opt_errorprefix cannot be empty" + } + if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { + error "$opt_errorprefix cannot contain whitespace" + } + return $name + } + + #split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path + #ignore trailing .tm .TM if present + #if version doesn't pass validation - treat it as part of the modulename and return empty version string without error + #Up to caller to validate. + proc split_modulename_version {modulename} { + set lastpart [namespace tail $modulename] + set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components + if {[string equal -nocase [file extension $modulename] ".tm"]} { + set fileparts [split [file rootname $lastpart] -] + } else { + set fileparts [split $lastpart -] + } + if {[punk::mix::util::is_valid_tm_version [lindex $fileparts end]]} { + set versionsegment [lindex $fileparts end] + set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch + } else { + # + set namesegment [join $fileparts -] + set versionsegment "" + } + return [list $namesegment $versionsegment] + } + + proc get_status {{workingdir ""} args} { + set result "" + if {$workingdir ne ""} { + if {[file pathtype $workingdir] ne "absolute"} { + set workingdir [file normalize $workingdir] + } + set active_dir $workingdir + } else { + set active_dir [pwd] + } + set defaults [dict create\ + -v 1\ + ] + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- + set opt_v [dict get $opts -v] + # -- --- --- --- --- --- --- --- --- + + + set repopaths [punk::repo::find_repos [pwd]] + set repos [dict get $repopaths repos] + if {![llength $repos]} { + append result [dict get $repopaths warnings] + } else { + append result [dict get $repopaths warnings] + lassign [lindex $repos 0] repopath repotypes + if {"fossil" in $repotypes} { + #review - multiple process launches to fossil a bit slow on windows.. + #could we query global db in one go instead? + # + set fossil_prog [auto_execok fossil] + append result "FOSSIL project based at $repopath with revision: [punk::repo::fossil_revision $repopath]" \n + set fosinfo [exec {*}$fossil_prog info] + append result [join [punk::repo::grep {repository:*} $fosinfo] \n] \n + + set fosrem [exec {*}$fossil_prog remote ls] + if {[string length $fosrem]} { + append result "Remotes:\n" + append result " " $fosrem \n + } + + + append result [join [punk::repo::grep {tags:*} $fosinfo] \n] \n + + set dbinfo [exec {*}$fossil_prog dbstat] + append result [join [punk::repo::grep {project-name:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {tickets:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {project-age:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {latest-change:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {files:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {check-ins:*} $dbinfo] \n] \n + if {"project" in $repotypes} { + #punk project + if {![catch {package require textblock; package require patternpunk}]} { + set result [textblock::join -- [>punk . logo] " " $result] + append result \n + } + } + + set timeline [exec fossil timeline -n 5 -t ci] + set timeline [string map {\r\n \n} $timeline] + append result $timeline + if {$opt_v} { + set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] + append result \n [punk::repo::workingdir_state_summary $repostate] + } + + } + #repotypes *could* be both git and fossil - so report both if so + if {"git" in $repotypes} { + append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n + if {[string length [set git_prog [auto_execok git]]]} { + set git_remotes [exec {*}$git_prog remote -v] + append result $git_remotes + if {$opt_v} { + set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] + append result \n [punk::repo::workingdir_state_summary $repostate] + } + } + } + + } + + return $result + } + + + proc build_modules_from_source_to_base {srcdir basedir args} { + set antidir [list "#*" "_build" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders (at any level) we don't want to search in or copy. + set defaults [list\ + -installer punk::mix::cli::build_modules_from_source_to_base\ + -call-depth-internal 0\ + -max_depth 1000\ + -subdirlist {}\ + -punkcheck_eventobj "\uFFFF"\ + -glob *.tm\ + -podglob #modpod-*\ + ] + set opts [dict merge $defaults $args] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set installername [dict get $opts -installer] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set CALLDEPTH [dict get $opts -call-depth-internal] + set max_depth [dict get $opts -max_depth] + set subdirlist [dict get $opts -subdirlist] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set fileglob [dict get $opts -glob] + set podglob [dict get $opts -podglob] + if {![string match "*.tm" $fileglob]} { + error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] + + set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing + set module_list [list] + + if {[file tail [file dirname $srcdir]] ne "src"} { + puts stderr "ERROR build_modules_from_source_to_base can only be called with a srcdir that is a subfolder of your 'src' directory" + puts stderr "The .tm modules are namespaced based on their directory depth - so we need to start at the root" + puts stderr "To build a subtree of your modules - use an appropriate src/modules folder and pass in the -subdirlist." + puts stderr "e.g if your modules are based at /x/src/modules2 and you wish to build only the .tm files at /x/src/modules2/skunkworks/lib" + puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" + exit 2 + } + set srcdirname [file tail $srcdir] + + set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir + if {[llength $subdirlist] == 0} { + set target_module_dir $basedir + set current_source_dir $srcdir + } else { + set target_module_dir $basedir/[file join {*}$subdirlist] + set current_source_dir $srcdir/[file join {*}$subdirlist] + } + if {![file exists $target_module_dir]} { + error "build_modules_from_source_to_base from current source dir: '$current_source_dir'. Basedir:'$current_module_dir' doesn't exist or is empty" + } + if {![file exists $current_source_dir]} { + error "build_modules_from_source_to_base from current source dir:'$current_source_dir' doesn't exist or is empty" + } + + #---------------------------------------- + set punkcheck_file [file join $basedir/.punkcheck] + if {$CALLDEPTH == 0} { + + set config [dict create\ + -glob $fileglob\ + -max_depth 0\ + ] + #lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list + # -- --- + set installer [punkcheck::installtrack new $installername $punkcheck_file] + $installer set_source_target $srcdir $basedir + set event [$installer start_event $config] + # -- --- + + } else { + set event $opt_punkcheck_eventobj + } + #---------------------------------------- + + + set process_modules [dict create] + #put pods first in processing order + set src_pods [glob -nocomplain -dir $current_source_dir -type d -tail $podglob] + foreach podpath $src_pods { + dict set process_modules $podpath [dict create -type pod] + } + set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] + foreach modulepath $src_modules { + dict set process_modules $modulepath [dict create -type file] + } + + set did_skip 0 ;#flag for stdout/stderr formatting only + dict for {modpath modinfo} $process_modules { + set modtype [dict get $modinfo -type] + + set is_interesting 0 + if {[string match "foobar" $current_source_dir]} { + set is_interesting 1 + } + if {$is_interesting} { + puts "build_modules_from_source_to_base >>> module $current_source_dir/$modpath" + } + set fileparts [split [file rootname $modpath] -] + #set tmfile_versionsegment [lindex $fileparts end] + lassign [split_modulename_version $modpath] basename tmfile_versionsegment + if {$tmfile_versionsegment eq ""} { + #split_modulename_version version part will be empty if not valid tcl version + #last segment doesn't look even slightly versiony - fail. + puts stderr "ERROR: Unable to confirm file $current_source_dir/$modpath is a reasonably versioned .tm module - ABORTING." + exit 1 + } + switch -- $modtype { + pod { + #basename still contains leading #modpod- + if {[string match #modpod-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, pod, unexpected basename $basename" ;#shouldn't be possible with default podglob - review - why is podglob configurable? + } + set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use) + if {$tmfile_versionsegment eq $magicversion} { + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\nWARNING: Missing buildversion text file: $versionfile" + puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" + set module_build_version "0.1" + } else { + set fd [open $versionfile r] + set versionfiledata [read $fd]; close $fd + set ln0 [lindex [split $versionfiledata \n] 0] + set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] + if {![util::is_valid_tm_version $ln0]} { + puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" + exit 3 + } + set module_build_version $ln0 + } + } else { + set module_build_version $tmfile_versionsegment + } + + set buildfolder $current_source_dir/_build + file mkdir $buildfolder + # -- --- + set config [dict create\ + -glob *\ + -max_depth 100\ + ] + # -max_depth -1 for no limit + set build_installername pods_in_$current_source_dir + set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] + $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_event [$build_installer start_event $config] + # -- --- + set podtree_copy $buildfolder/#modpod-$basename-$module_build_version + set modulefile $buildfolder/$basename-$module_build_version.tm + + + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath + if {$tmfile_versionsegment eq $magicversion} { + $build_event targetset_addsource $versionfile + } + if {\ + [llength [dict get [$build_event targetset_source_changes] changed]]\ + || [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\ + } { + $build_event targetset_started + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + + set delete_failed 0 + if {[file exists $buildfolder/]} { + puts stderr "deleting existing _build copy at $podtree_copy" + if {[catch { + file delete -force $podtree_copy + } errMsg]} { + puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$current_source_dir/$modpath" + puts stdout "to:" + puts stdout "$podtree_copy" + file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { + set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm + if {[file exists $tmfile]} { + set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm + file rename $tmfile $newname + set tmfile $newname + } + set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $tmfile w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + } + #delete and regenerate zip and modpod stubbed zip + set had_error 0 + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.zip + } err] } { + set had_error 1 + lappend notes "zip_delete_failed" + } + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary zip file without using external executable + package require punk::zip + set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate) + + if 0 { + #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise + punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * + #punk::zip::mkzip stores permissions - (unix style) which confuses zipfs when reading - it misidentifies dirs as files + } + #zipfs mkzip does exactly what we need anyway in this case + set wd [pwd] + cd $buildfolder + puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" + zipfs mkzip $zipfile #modpod-$basename-$module_build_version + cd $wd + + package require modpod + modpod::lib::make_zip_modpod $zipfile $modulefile + + + if {$had_error} { + $build_event targetset_end FAILED -note [join $notes ,] + } else { + # -- ---------- + $build_event targetset_end OK + # -- ---------- + } + } else { + $build_event targetset_end FAILED -note "could not delete $podtree_copy" + } + + } else { + puts -nonewline stderr "." + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $build_event targetset_end SKIPPED + } + $build_event destroy + $build_installer destroy + + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + file copy -force $modulefile $target_module_dir + puts stderr "Copied zip modpod module $modulefile to $target_module_dir" + # -- --- --- --- --- --- + $event targetset_end OK -note "zip modpod" + } else { + puts -nonewline stderr "." + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } + tarjar { + #basename may still contain #tarjar- + #to be obsoleted - update modpod to (optionally) use vfs::tar + } + file { + set m $modpath + if {$tmfile_versionsegment eq $magicversion} { + #set basename [join [lrange $fileparts 0 end-1] -] + set versionfile $current_source_dir/$basename-buildversion.txt + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\nWARNING: Missing buildversion text file: $versionfile" + puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" + set module_build_version "0.1" + } else { + set fd [open $versionfile r] + set versionfiledata [read $fd]; close $fd + set ln0 [lindex [split $versionfiledata \n] 0] + set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] + if {![util::is_valid_tm_version $ln0]} { + puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" + exit 3 + } + set module_build_version $ln0 + } + + + if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { + #rebuild the .tm from the #tarjar + + if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { + + } else { + + } + #REVIEW - should be in same structure/depth as $target_module_dir in _build? + + #TODO + set buildfolder $current_sourcedir/_build + file mkdir $buildfolder + + set tmfile $buildfolder/$basename-$module_build_version.tm + file delete -force $buildfolder/#tarjar-$basename-$module_build_version + file delete -force $tmfile + + + file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version + # + #bsdtar doesn't seem to work.. or I haven't worked out the right options? + #exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version + package require tar + tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version + if {![file exists $tmfile]} { + puts stdout "ERROR: failed to build tarjar file $tmfile" + exit 4 + } + #copy the file? + #set target $target_module_dir/$basename-$module_build_version.tm + #file copy -force $tmfile $target + + lappend module_list $tmfile + } else { + #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. + if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { + puts stderr "\nWarning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" + } + + #------------------------------ + # + #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] + #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $versionfile + $event targetset_addsource $current_source_dir/$m + + #set changed_list [list] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] + #set changed_list [dict get $changed_unchanged changed] + + + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + #set file_record [punkcheck::installfile_started_install $basedir $file_record] + $event targetset_started + # -- --- --- --- --- --- + set target $target_module_dir/$basename-$module_build_version.tm + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" + set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $target w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + #file copy -force $srcdir/$m $target + lappend module_list $target + # -- --- --- --- --- --- + #set file_record [punkcheck::installfile_finished_install $basedir $file_record] + $event targetset_end OK + } else { + if {$is_interesting} { + puts stdout "skipping module $current_source_dir/$m - no change in sources detected" + } + puts -nonewline stderr "." + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + + #------------------------------ + + } + + continue + } + ##------------------------------ + ## + #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] + #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] + #set changed_list [list] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] + #set changed_list [dict get $changed_unchanged changed] + #---------- + $event targetset_init INSTALL $target_module_dir/$m + $event targetset_addsource $current_source_dir/$m + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + #set file_record [punkcheck::installfile_started_install $basedir $file_record] + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $current_source_dir/$m + file copy -force $current_source_dir/$m $target_module_dir + puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir" + # -- --- --- --- --- --- + #set file_record [punkcheck::installfile_finished_install $basedir $file_record] + $event targetset_end OK -note "already versioned module" + } else { + puts -nonewline stderr "." + set did_skip 1 + if {$is_interesting} { + puts stderr "$current_source_dir/$m [$event targetset_source_changes]" + } + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + } + } + } ;#end dict for {modpath modinfo} $process_modules + + + if {$CALLDEPTH >= $max_depth} { + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + set skipdir 0 + foreach dg $antidir { + if {[string match $dg $d]} { + set skipdir 1 + continue + } + } + if {$skipdir} { + continue + } + if {![file exists $target_module_dir/$d]} { + file mkdir $target_module_dir/$d + } + lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\ + -call-depth-internal [expr {$CALLDEPTH +1}]\ + -subdirlist [list {*}$subdirlist $d]\ + -punkcheck_eventobj $event\ + -glob $fileglob\ + -podglob $podglob\ + ] + } + if {$did_skip} { + puts -nonewline stdout \n + } + if {$CALLDEPTH == 0} { + $event destroy + $installer destroy + } + return $module_list + } + + variable kettle_reset_bodies [dict create] + variable kettle_reset_args [dict create] + #We are abusing kettle to run in-process. + # when we change to another project we need recipes to be reloaded. + # Kettle rewrites some of it's own procs - stopping reloading of recipes when we change folders + #kettle_init stores the original proc bodies & args + proc kettle_init {} { + variable kettle_reset_bodies ;#dict + variable kettle_reset_args + set reset_procs [list\ + ::kettle::benchmarks\ + ::kettle::doc\ + ::kettle::figures\ + ::kettle::meta::scan\ + ::kettle::testsuite\ + ] + foreach p $reset_procs { + set b [info body $p] + if {[string match "*Overwrite self*" $b]} { + dict set kettle_reset_bodies $p $b + set argnames [info args $p] + set arglist [list] + foreach a $argnames { + if {[info default $p $a dval]} { + lappend arglist [list $a $dval] + } else { + lappend arglist $a + } + } + dict set kettle_reset_args $p $arglist + } + } + + } + #call kettle_reinit to ensure recipes point to current project + proc kettle_reinit {} { + variable kettle_reset_bodies + variable kettle_reset_args + dict for {p b} $kettle_reset_bodies { + #set b [dict get $kettle_reset_bodies $p] + set argl [dict get $kettle_reset_args $p] + uplevel 1 [list ::proc $p $argl $b] + } + #todo - determine standard recipes by examining standard.tcl instead of hard coding? + set standard_recipes [list\ + null\ + forever\ + list-recipes\ + help-recipes\ + help-dump\ + help-recipes\ + help\ + list\ + list-options\ + help-options\ + show-configuration\ + show-state\ + show\ + meta-status\ + gui\ + ] + #set ::kettle::recipe::recipe [dict create] + dict for {r -} $::kettle::recipe::recipe { + if {$r ni $standard_recipes} { + dict unset ::kettle::recipe::recipe $r + } + } + } + proc kettle_call {calltype args} { + variable kettle_reset_bodies + switch -- $calltype { + lib {} + shell { + set kettleappfile [file dirname [info nameofexecutable]]/kettle + set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat + + if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { + error "deck kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" + } + if {[file exists $kettleappfile]} { + set kettlescript $kettleappfile + } + if {$::tcl_platform(platform) eq "windows"} { + if {[file exists $kettlebatfile]} { + set kettlescript $kettlebatfile + } + } + } + default { + error "deck kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" + } + } + set startdir [pwd] + if {![file exists $startdir/build.tcl]} { + error "deck kettle must be run from a folder containing build.tcl (cwd: [pwd])" + } + if {[package provide kettle] eq ""} { + puts stdout "Loading kettle package - may be delay on first load ..." + package require kettle + kettle_init ;#store original procs for those kettle procs that rewrite themselves + } else { + if {[dict size $kettle_reset_bodies] == 0} { + #presumably package require kettle was called without calling our kettle_init hack. + kettle_init + } else { + #undo proc rewrites + kettle_reinit + } + } + set first [lindex $args 0] + if {[string match @* $first]} { + error "deck kettle doesn't support special operations - try calling tclsh kettle directly" + } + if {$first eq "-f"} { + set args [lassign $args __ path] + } else { + set path $startdir/build.tcl + } + set opts [list] + + if {[lindex $args 0] eq "-trace"} { + set args [lrange $args 1 end] + lappend opts --verbose on + } + set goals [list] + + if {$calltype eq "lib"} { + file mkdir ~/.kettle + set dotfile ~/.kettle/config + if {[file exists $dotfile] && + [file isfile $dotfile] && + [file readable $dotfile]} { + ::kettle io trace {Loading dotfile $dotfile ...} + set args [list {*}[::kettle path cat $dotfile] {*}$args] + } + } + + #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names + #This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) + #REVIEW - needs to be updated to keep in sync with kettle. + set knownopts [list\ + --exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ + --ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ + --log-append --log-mode --with-dia --constraints --file --limitconstraints --tmatch --notfile --single --valgrind --tskip --repeats \ + --iters --collate --match --rmatch --with-doc-destination --with-git --target --test-include \ + ] + + while {[llength $args]} { + set o [lindex $args 0] + switch -glob -- $o { + --* { + #instead of using: kettle option known + if {$o ni $knownopts} { + error "Unable to process unknown option $o." {} [list KETTLE (deck)] + } + lappend opts $o [lindex $args 1] + #::kettle::option set $o [lindex $args 1] + set args [lrange $args 2 end] + } + default { + lappend goals $o + set args [lrange $args 1 end] + } + } + } + + if {![llength $goals]} { + lappend goals help + } + if {"--prefix" ni [dict keys $opts]} { + dict set opts --prefix [file dirname $startdir] + } + if {$calltype eq "lib"} { + ::kettle status clear + ::kettle::option::set @kettle $startdir + foreach {o v} $opts { + ::kettle option set $o $v + } + ::kettle option set @srcscript $path + ::kettle option set @srcdir [file dirname $path] + ::kettle option set @goals $goals + #load standard recipes as listed in build.tcl + ::source $path + puts stderr "recipes: [::kettle recipe names]" + ::kettle recipe run {*}[::kettle option get @goals] + + set state [::kettle option get --state] + if {$state ne {}} { + puts stderr "saving kettle state: $state" + ::kettle status save $state + } + + } else { + #shell + puts stdout "Running external kettle process with args: $opts $goals" + run -n tclsh $kettlescript -f $path {*}$opts {*}$goals + } + + } + proc kettle_punk_recipes {} { + set txtdst ... + } + + } +} + + +namespace eval punk::mix::cli { + proc _cli {args} { + #don't use tailcall - base uses info level to determine caller + ::punk::mix::base::_cli {*}$args + } + variable default_command help + package require punk::mix::base + package require punk::overlay + if {[catch { + punk::overlay::custom_from_base [namespace current] ::punk::mix::base + } errM]} { + puts stderr "punk::mix::cli load error: Failed to overlay punk::mix::base $errM" + error "punk::mix::cli error: $errM" + } +} + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::cli [namespace eval punk::mix::cli { + variable version + set version 0.3 +}] +return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm index 883e02d2..409796fc 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm @@ -49,7 +49,7 @@ namespace eval punk::mix::commandset::buildsuite { set path_parts [file split [lindex $du_record 1]] ;#should handle spaced-paths ok. set s [lindex $path_parts end-1] set p [lindex $path_parts end] - + #This handles case where a project folder is same name as suite e.g src/buildsuites/tcl/tcl #so we can't just use tail as dict key. We could assume last record is always total - but if {![string match -nocase $s $suite]} { diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm index c6c83b69..a3784c00 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm @@ -26,7 +26,7 @@ namespace eval punk::mix::commandset::debug { namespace export get paths namespace path ::punk::mix::cli - #Except for 'get' - all debug commands should emit to stdout + #Except for 'get' - all debug commands should emit to stdout proc paths {} { set out "" puts stdout "find_repos output:" @@ -40,7 +40,7 @@ namespace eval punk::mix::commandset::debug { set template_base_dict [punk::mix::base::lib::get_template_basefolders] puts stdout "get_template_basefolders output:" pdict template_base_dict */* - return + return } #call other debug command - but capture stdout as return value @@ -84,9 +84,9 @@ namespace eval punk::mix::commandset::debug { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug { 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/punk/mix/commandset/doc-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm index fafc3cec..fa9e8d7c 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm @@ -22,7 +22,7 @@ package require punk::path ;# for treefilenames, relative package require punk::repo package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call -#package require punk::mix::util ;#for path_relative +#package require punkcheck ;#for path_relative # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -48,6 +48,7 @@ namespace eval punk::mix::commandset::doc { set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man] foreach maybedoomed $oldfiles { set fd [open $maybedoomed r] + chan conf $fd -translation binary set data [read $fd] close $fd if {[string match "*--- punk::docgen overwrites *" $data]} { @@ -165,7 +166,18 @@ namespace eval punk::mix::commandset::doc { cd $original_wd } - proc validate {} { + proc validate {args} { + set argd [punk::args::get_dict { + @id -id ::punk::mix::commandset::doc::validate + -- -type none -optional 1 -help "end of options marker --" + -individual -type boolean -default 1 + @values -min 0 -max -1 + patterns -default {*.man} -type any -multiple 1 + } $args] + set opt_individual [tcl::dict::get $argd opts -individual] + set patterns [tcl::dict::get $argd values patterns] + + #todo - run and validate punk::docgen output set projectdir [punk::repo::find_project] if {$projectdir eq ""} { @@ -180,7 +192,23 @@ namespace eval punk::mix::commandset::doc { set docroot $projectdir/src/doc cd $docroot - dtplite validate $docroot + if {!$opt_individual && "*.man" in $patterns} { + if {[catch { + dtplite validate $docroot + } errM]} { + puts stderr "commandset::doc::validate failed for projectdir '$projectdir'" + puts stderr "docroot '$docroot'" + puts stderr "dtplite error was: $errM" + } + } else { + foreach p $patterns { + set treefiles [punk::path::treefilenames $p] + foreach path $treefiles { + puts stdout "dtplite validate $path" + dtplite validate $path + } + } + } #punk::mix::cli::lib::kettle_call lib validate-doc @@ -225,6 +253,7 @@ namespace eval punk::mix::commandset::doc { append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n foreach fullpath $matched_paths { + puts stdout "do_docgen processing: $fullpath" set doctools [punk::docgen::get_doctools_comments $fullpath] if {$doctools ne ""} { set fname [file tail $fullpath] @@ -245,7 +274,12 @@ namespace eval punk::mix::commandset::doc { #this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. #review - if we're checking fname - should also test length of whole path and determine limits for tar package require md5 - set target_docname [md5::md5 -hex [encoding convertto utf-8 $fullpath]]_overlongfilename.man + if {[package vsatisfies [package present md5] 2- ] } { + set md5opt "-hex" + } else { + set md5opt "" + } + set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man puts stderr "WARNING - overlong file name - renaming $fullpath" puts stderr " to [file dirname $fullpath]/$target_docname" } diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm index 401ddb72..05e94a25 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm @@ -22,7 +22,8 @@ package require punk::args #sort of a circular dependency when commandset loaded by punk::mix::cli - that's ok, but this could theoretically be loaded by another cli and with another base package require punk::mix package require punk::mix::base - +package require punk::lib +package require textblock # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -30,19 +31,48 @@ namespace eval punk::mix::commandset::layout { namespace export * + namespace eval argdoc { + proc layout_names {} { + if {[catch {punk::mix::commandset::layout::lib::layouts_dict *} ldict]} { + #REVIEW + return "punk.project" + } else { + return [dict keys $ldict] + } + } + } #per layout functions - proc files {{layout ""}} { - set argd [punk::args::get_dict { - *values -min 1 -max 1 - layout -type string -minlen 1 - } [list $layout]] + punk::args::define { + @dynamic + @id -id ::punk::mix::commandset::layout::files + -datetime -default "%Y-%m-%dT%H:%M:%S" -help\ + "Datetime format for mtime. Use empty string for no datetime output" + @values -min 1 -max 1 + layout -type string -choices {${[punk::mix::commandset::layout::argdoc::layout_names]}} + } + proc files {args} { + set argd [punk::args::get_by_id ::punk::mix::commandset::layout::files $args] + set layout [dict get $argd values layout] + set dtformat [dict get $argd opts -datetime] set allfiles [lib::layout_all_files $layout] - return [join $allfiles \n] + if {$dtformat eq ""} { + return [join $allfiles \n] + } else { + set out "" + foreach f $allfiles { + set mtime [dict get [file stat $f] mtime] + append out "$f [clock format $mtime -format $dtformat]" \n + } + set out [string range $out 0 end-1] + return $out + } } proc templatefiles {layout} { - set templatefiles [lib::layout_scan_for_template_files $layout] - return [join $templatefiles \n] + set templatefiles_and_tags [lib::layout_scan_for_template_files $layout] + set flatlist [punk::lib::lmapflat v $templatefiles_and_tags {lrange $v 0 end}] + #return [join $templatefiles \n] + textblock::list_as_table -header {"File with tags found" "Tags"} -columns 2 $flatlist } proc templatefiles.relative {layout} { @@ -56,12 +86,14 @@ namespace eval punk::mix::commandset::layout { set stripprefix [file normalize $layoutfolder] - set templatefiles [lib::layout_scan_for_template_files $layout] - set tails [list] - foreach templatefullpath $templatefiles { - lappend tails [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + set templatefiles_and_tags [lib::layout_scan_for_template_files $layout] + set flatlist [list] + foreach entry $templatefiles_and_tags { + lassign $entry templatefullpath tags + lappend flatlist [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] $tags } - return [join $tails \n] + #return [join $tails \n] + textblock::list_as_table -header {"File with tags found" "Tags"} -columns 2 $flatlist } #layout collection functions - to be imported with punk::overlay::import_commandset separately @@ -83,7 +115,8 @@ namespace eval punk::mix::commandset::layout { proc _default {args} { punk::args::get_dict [subst { - *proc -name ::punk::mix::commandset::layout::collection::_default + @id -id ::punk::mix::commandset::layout::collection::_default + @cmd -name ::punk::mix::commandset::layout::collection::_default -startdir -type string -not -type string -multiple 1 globsearches -default * -multiple 1 @@ -110,28 +143,16 @@ namespace eval punk::mix::commandset::layout { } set title(path) "Path" - set widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]] - set col(path) [string repeat " " $widest(path)] set title(pathtype) "[a+ green]Path Type[a]" - set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {punk::strlen $v}]] - set col(pathtype) [string repeat " " $widest(pathtype)] set title(name) "Layout Name" - set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {punk::strlen $v}]] - set col(name) [string repeat " " $widest(name)] - - set vsep " | " - set vsep_w [string length $vsep] ;#unicode? - set tablewidth [expr {$widest(name) + $vsep_w + $widest(pathtype) + $vsep_w + $widest(path)}] - set table "" - append table [string repeat - $tablewidth] \n - append table "[textblock::join -- [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n - append table [string repeat - $tablewidth] \n + set data [list] foreach n $names pt $pathtypes p $paths { - append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n + lappend data $n $pt $p } + set table [textblock::list_as_table -columns 3 -header [list $title(name) $title(pathtype) $title(path)] $data] return $table } @@ -156,35 +177,22 @@ namespace eval punk::mix::commandset::layout { lappend pathtypes [dict get $tinfo sourceinfo pathtype] } - set title(path) "Path" - set widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]] - set col(path) [string repeat " " $widest(path)] - - set title(pathtype) "[a+ green]Path Type[a]" - set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {punk::strlen $v}]] - set col(pathtype) [string repeat " " $widest(pathtype)] - set title(name) "Layout Name" - set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {punk::strlen $v}]] - set col(name) [string repeat " " $widest(name)] - - set vsep " | " - set vsep_w [string length $vsep] ;#unicode? - set tablewidth [expr {$widest(name) + $vsep_w + $widest(pathtype) + $vsep_w + $widest(path)}] - set table "" - append table [string repeat - $tablewidth] \n - append table "[textblock::join -- [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n - append table [string repeat - $tablewidth] \n + set title(pathtype) "[a+ green]Path Type[a]" + set title(path) "Path" + set data [list] foreach n $names pt $pathtypes p $paths { - append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n + #append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n + lappend data $n $pt $p } + set table [textblock::list_as_table -columns 3 -header [list $title(name) $title(pathtype) $title(path)] $data] return $table } proc as_dict {args} { - tailcall punk::mix::commandset::layout::lib::layouts_dict {*}$args + punk::mix::commandset::layout::lib::layouts_dict {*}$args } proc references_as_dict {args} { package require punk::cap @@ -243,7 +251,7 @@ namespace eval punk::mix::commandset::layout { #todo - get standard tags from somewhere set tagnames [list project] foreach tn $tagnames { - lappend tags [string cat % $tn %] + lappend tags [string cat % $tn %] ;#make sure actual tag literal doesn't appear in this source file } } set file_list [list] @@ -252,11 +260,15 @@ namespace eval punk::mix::commandset::layout { fconfigure $fd -translation binary set data [read $fd] close $fd - foreach tag $tags { + set found_tags [list] + foreach tag $tags tn $tagnames { if {[string match "*$tag*" $data]} { - lappend file_list $path + lappend found_tags $tn } } + if {[llength $found_tags]} { + lappend file_list [list $path $found_tags] + } } return $file_list diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index bd0b5358..b964d228 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -1,5 +1,5 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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. @@ -26,19 +26,25 @@ package require punk::lib namespace eval punk::mix::commandset::loadedlib { namespace export * #search automatically wrapped in * * - can contain inner * ? globs - proc search {args} { - set argspecs { - *proc -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" - -return -type string -default table -choices {table tableobject list lines} - -present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help "(unimplemented) Display only those that are 0:absent 1:present 2:both" - -highlight -type boolean -default 1 -help "Highlight which version is present with ansi underline and colour" - -refresh -default 0 -type boolean -help "Re-scan the tm and library folders" - searchstrings -default * -multiple 1 -help "Names to search for, may contain glob chars (* ?) e.g *lib* + punk::args::define { + @id -id ::punk::mix::commandset::loadedlib::search + @cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" + -return -type string -default table -choices {table tableobject list lines} + -present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\ + "(unimplemented) Display only those that are 0:absent 1:present 2:either" + -highlight -type boolean -default 1 -help\ + "Highlight which version is present with ansi underline and colour" + -refresh -default 0 -type boolean -help "Re-scan the tm and library folders" + searchstrings -default * -multiple 1 -help\ + "Names to search for, may contain glob chars (* ?) e.g *lib* If no glob chars are explicitly specified, the searchstring will be wrapped with star globs. - eg name -> *name* + eg name -> *name* + To search for an exact name prefix it with = + e.g =name -> name " - } - set argd [punk::args::get_dict $argspecs $args] + } + proc search {args} { + set argd [punk::args::get_by_id ::punk::mix::commandset::loadedlib::search $args] set searchstrings [dict get $argd values searchstrings] set opts [dict get $argd opts] set opt_return [dict get $opts -return] @@ -53,7 +59,7 @@ namespace eval punk::mix::commandset::loadedlib { set packages [package names] set matches [list] foreach search $searchstrings { - if {[regexp {[?*]} $search]} { + if {[regexp {[?*\[]} $search]} { #caller has specified specific glob pattern - use it #todo - respect supplied case only if uppers present? require another flag? lappend matches {*}[lsearch -all -inline -nocase $packages $search] @@ -298,11 +304,12 @@ namespace eval punk::mix::commandset::loadedlib { } set versions [package versions [lindex $libfound 0]] - if {$has_natsort} { - set versions [natsort::sort $versions] - } else { - set versions [lsort $versions] - } + set versions [lsort -command {package vcompare} $versions] + #if {$has_natsort} { + # set versions [natsort::sort $versions] + #} else { + # set versions [lsort $versions] + #} if {![llength $versions]} { error "No version numbers found for library/module $libfound - sorry, you will need to copy it across manually" } diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index 9955c53b..2bc0f01c 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -26,8 +26,10 @@ namespace eval punk::mix::commandset::module { namespace export * proc paths {} { - set roots [punk::repo::find_repos ""] - set project [lindex [dict get $roots project] 0] + #set roots [punk::repo::find_repos ""] + #set project [lindex [dict get $roots project] 0] + set project [punk::repo::find_project ""] + if {$project ne ""} { set is_project 1 set searchbase $project @@ -120,16 +122,20 @@ namespace eval punk::mix::commandset::module { return $table } - #return all module templates with repeated ones suffixed with .2 .3 etc + + #return all module templates with repeated ones suffixed with #2 #3 etc + punk::args::define { + @id -id ::punk::mix::commandset::module::templates_dict + @cmd -name templates_dict -help\ + "Templates from module and project paths" + -startdir -default "" -help\ + "Project folder used in addition to module paths" + -not -default "" -multiple 1 + @values + globsearches -default * -multiple 1 + } proc templates_dict {args} { - set argspec { - *proc -name templates_dict -help "Templates from module and project paths" - -startdir -default "" -help "Project folder used in addition to module paths" - -not -default "" -multiple 1 - *values - globsearches -default * -multiple 1 - } - set argd [punk::args::get_dict $argspec $args] + set argd [punk::args::get_by_id ::punk::mix::commandset::module::templates_dict $args] package require punk::cap if {[punk::cap::capability_has_handler punk.templates]} { set template_folder_dict [punk::cap::call_handler punk.templates get_itemdict_moduletemplates {*}$args] @@ -137,23 +143,40 @@ namespace eval punk::mix::commandset::module { put stderr "get_template_basefolders WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations" } } + + + set moduletypes [punk::mix::cli::lib::module_types] + punk::args::define [subst { + @id -id ::punk::mix::commandset::module::new + @cmd -name "punk::mix::commandset::module::new" -help\ + "Create a new module file in the appropriate folder within src/modules. + If the name given in the module argument is namespaced, + the necessary subfolder(s) will be used or created." + -project -optional 1 + -version -default "0.1.0" -help\ + "version to use if not specified as part of the module argument. + If a version is specified in the module argument as well as in -version + the higher version number will be used. + " + -license -default + -author -default -multiple 1 + -template -default punk.module + -type -default "[lindex $moduletypes 0]" -choices {$moduletypes} + -force -default 0 -type boolean -help\ + "If set true, will OVERWRITE an existing .tm file if there is one. + If false (default) an error will be raised if there is a conflict." + -quiet -default 0 -type boolean -help\ + "Suppress information messages on stdout" + @values -min 1 -max 1 + module -type string -help\ + "Name of module, possibly including a namespace and/or version number + e.g mynamespace::mymodule-1.0" + }] proc new {args} { set year [clock format [clock seconds] -format %Y] - set moduletypes [punk::mix::cli::lib::module_types] # use \uFFFD because unicode replacement char should consistently render as 1 wide - set argspecs [subst { - -project -default \uFFFD - -version -default \uFFFD - -license -default - -template -default punk.module - -type -default \uFFFD -choices {$moduletypes} - -force -default 0 -type boolean - -quiet -default 0 -type boolean - *values -min 1 -max 1 - module -type string - }] - set argd [punk::args::get_dict $argspecs $args] - lassign [dict values $argd] opts values + set argd [punk::args::get_by_id ::punk::mix::commandset::module::new $args] + lassign [dict values $argd] leaders opts values received set module [dict get $values module] #set opts [dict merge $defaults $args] @@ -168,13 +191,9 @@ namespace eval punk::mix::commandset::module { # we need this value before looking at the named argument # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_version_supplied [dict get $opts -version] - if {$opt_version_supplied eq "\uFFFD"} { - set opt_version "0.1.0" - } else { - set opt_version $opt_version_supplied - if {![util::is_valid_tm_version $opt_version]} { - error "deck module.new error - supplied -version $opt_version doesn't appear to be a valid Tcl module version" - } + set opt_version $opt_version_supplied + if {![util::is_valid_tm_version $opt_version]} { + error "deck module.new error - supplied -version $opt_version doesn't appear to be a valid Tcl module version" } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- #named argument @@ -194,7 +213,7 @@ namespace eval punk::mix::commandset::module { } else { set vmsg "from -version option: $opt_version_supplied" } - if {$opt_version_supplied ne "\uFFFD"} { + if {"-version" in $received} { if {$vcompare_is_mversion_bigger != 0} { #is bigger or smaller puts stderr "module.new WARNING: version supplied in module argument as well as -version option. Using the higher version number $vmsg" @@ -204,10 +223,33 @@ namespace eval punk::mix::commandset::module { set modulename $module } punk::mix::cli::lib::validate_modulename $modulename -errorprefix "punk::mix::commandset::module::new" + + if {[regexp {[A-Z]} $module]} { + set msg "module names containing uppercase are not recommended (see tip 590).\n" + append msg "Please retype the module name '$module' to proceed.\n" + append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" + append msg "Retype it all in lowercase to use recommended naming" + set answer [util::askuser $msg] + if {[regexp {[A-Z]} $answer]} { + if {$answer eq $module} { + #ok - user insists + } else { + + } + } else { + #user has resupplied modulename all as lowercase + if {$answer eq [string tolower $module]} { + set module $answer + } else { + #.. but it doesn't match original - require rerun + } + } + } + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- #options # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_project [dict get $opts -project] set testdir [pwd] if {![string length [set projectdir [punk::repo::find_project $testdir]]]} { if {![string length [set projectdir [punk::repo::find_candidate $testdir]]]} { @@ -215,9 +257,10 @@ namespace eval punk::mix::commandset::module { error "module.new unable to create module in projectdir:$projectdir - directory doesn't appear to meet basic standards $msg" } } - if {$opt_project == "\uFFFF"} { + if {![dict exists $received -project]} { set projectname [file tail $projectdir] } else { + set opt_project [dict get $opts -project] set projectname $opt_project if {$projectname ne [file tail $projectdir]} { error "module.new -project '$opt_project' doesn't match detected projectname '$projectname' at path: $projectdir" @@ -225,6 +268,7 @@ namespace eval punk::mix::commandset::module { } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_license [dict get $opts -license] + set opt_authors [dict get $opts -author] ;#-multiple true # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_template [dict get $opts -template] if {[regexp {.*[?*].*} $opt_template]} { @@ -285,12 +329,6 @@ namespace eval punk::mix::commandset::module { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_type [dict get $opts -type] - if {$opt_type eq "\uFFFD"} { - set opt_type [lindex [punk::mix::cli::lib::module_types] 0] ;#default to plain - } - if {$opt_type ni [punk::mix::cli::lib::module_types]} { - error "module.new - error - unknown -type '$opt_type' known-types: [punk::mix::cli::lib::module_types]" - } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_quiet [dict get $opts -quiet] set opt_force [dict get $opts -force] @@ -372,7 +410,7 @@ namespace eval punk::mix::commandset::module { #for now the user has the option to override any templates and remove %moduletemplate% if it is a security/privacy concern #Don't put literal %x% in the code for the commandset::module itself - to stop them being seen by layout scanner as replacable tokens - set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename year $year license $opt_license version $infile_version] + set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename year $year license $opt_license authors $opt_authors version $infile_version] set strmap [list] foreach {tag val} $tagnames { lappend strmap %$tag% $val @@ -383,7 +421,7 @@ namespace eval punk::mix::commandset::module { set podfile $modulefolder/#modpod-$moduletail-$infile_version/$moduletail-$infile_version.tm set has_tm [file exists $tmfile] set has_pod [file exists $podfile] - if {$has_tm && $has_pos} { + if {$has_tm && $has_pod} { #invalid configuration - bomb out error "module.new error: Invalid target configuration found. module folder has both a .tm file $tmfile and a modpod file $podfile. Please delete one of them before trying again." } @@ -424,7 +462,7 @@ namespace eval punk::mix::commandset::module { } set buildversionfile [file join $modulefolder ${moduletail}-buildversion.txt] set existing_build_version "" - if {[file exists $buildversionfile]} { + if {!$opt_force && [file exists $buildversionfile]} { set buildversiondata [punk::mix::util::fcat $buildversionfile] set lines [split $buildversiondata \n] set existing_build_version [string trim [lindex $lines 0]] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index aa630d36..f670c8c0 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.0] #[copyright "2023"] #[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] -#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] +#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] #[require punk::mix::commandset::project] #[description] @@ -29,25 +29,25 @@ #*** !doctools #[section Overview] #[para] overview of punk::mix::commandset::project -#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g +#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g #[example { # namespace eval myproject::cli { # namespace export * # namespace ensemble create # package require punk::overlay -# +# # package require punk::mix::commandset::project # punk::overlay::import_commandset project . ::punk::mix::commandset::project -# punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection +# punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection # } #}] #[para] Where the . in the above example is the prefix/command separator #[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. -#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new +#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new #[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as projects. #[para] #[subsection Concepts] -#[para] see punk::overlay +#[para] see punk::overlay # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -56,7 +56,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::mix::commandset::project +#[para] packages used by punk::mix::commandset::project #[list_begin itemized] package require Tcl 8.6- @@ -88,7 +88,7 @@ namespace eval punk::mix::commandset::project { namespace export * #*** !doctools #[subsection {Namespace punk::mix::commandset::project}] - #[para] core commandset functions for punk::mix::commandset::project + #[para] core commandset functions for punk::mix::commandset::project #[list_begin definitions] proc _default {} { @@ -109,12 +109,31 @@ namespace eval punk::mix::commandset::project { } - + namespace eval argdoc { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + variable LAYOUTNAMES [dict keys $layout_dict] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::new + @cmd -name "punk::mix::commandset::project::new" -help\ + "" + @leaders -min 1 -max 1 + project -type string -help\ + "Project name or path. + If just a name is given ... (todo)" + @opts + -type -default plain + -empty -default 0 -type boolean + -force -default 0 -type boolean + -update -default 0 -type boolean + -confirm -default 1 -type boolean + -layout -default "punk.project" -choices {${$::punk::mix::commandset::project::argdoc::LAYOUTNAMES}} + } proc new {newprojectpath_or_name args} { #*** !doctools # [call [fun new] [arg newprojectpath_or_name] [opt args]] - #new project structure - may be dedicated to one module, or contain many. + #new project structure - may be dedicated to one module, or contain many. #create minimal folder structure only by specifying in args: -modules {} if {[file pathtype $newprojectpath_or_name] eq "absolute"} { set projectfullpath [file normalize $newprojectpath_or_name] @@ -157,21 +176,21 @@ namespace eval punk::mix::commandset::project { set opt_force [dict get $opts -force] set opt_confirm [string tolower [dict get $opts -confirm]] # -- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_layout [dict get $opts -layout] + set opt_update [dict get $opts -update] + # -- --- --- --- --- --- --- --- --- --- --- --- --- set opt_modules [dict get $opts -modules] if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { #if not specified - add a single module matching project name if {$opt_force || $opt_update} { #generally undesirable to add default project module during an update. #user can use dev module.new manually or supply module name in -modules - set opt_modules [list] + set opt_modules [list] } else { - set opt_modules [list $projectname] + set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl } } # -- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_layout [dict get $opts -layout] - set opt_update [dict get $opts -update] - # -- --- --- --- --- --- --- --- --- --- --- --- --- #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache @@ -188,12 +207,12 @@ namespace eval punk::mix::commandset::project { } #we don't assume 'unknown' is configured to run shell commands if {[string length [package provide shellrun]]} { - set exitinfo [run {*}$scoop_prog install fossil] + set exitinfo [run {*}$scoop_prog install fossil] #scoop tends to return successful exitcode (0) even when packages not found etc. - so exitinfo not much use. puts stdout "scoop install fossil ran with result: $exitinfo" } else { puts stdout "Please wait while scoop runs - there may be a slight delay and then scoop output will be shown. (use punk shellrun package for )" - set result [exec {*}$scoop_prog install fossil] + set result [exec {*}$scoop_prog install fossil] puts stdout $result } catch {::auto_reset} ;#can be missing (unsure under what circumstances - but I've seen it raise error 'invalid command name "auto_reset"') @@ -285,7 +304,7 @@ namespace eval punk::mix::commandset::project { } } - + set project_dir_exists [file exists $projectdir] if {$project_dir_exists && !($opt_force || $opt_update)} { puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" @@ -300,10 +319,20 @@ namespace eval punk::mix::commandset::project { } } } elseif {$project_dir_exists && $opt_update} { - puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items" + set warnmsg "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items" + if {$opt_confirm} { + puts stderr $warnmsg + set msg "Do you want to proceed to possibly overwrite some existing files in $projectdir? Y|N" + set answer [util::askuser $msg] + if {[string tolower $answer] ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompt." + return + } + } + puts stderr $warnmsg } - set fossil_repo_file "" + set fossil_repo_file "" set is_fossil_root 0 if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} { set is_fossil_root 1 @@ -327,7 +356,7 @@ namespace eval punk::mix::commandset::project { return } #review - set fossil_repo_file $repodb_folder/$projectname.fossil + set fossil_repo_file $repodb_folder/$projectname.fossil } if {$fossil_repo_file eq ""} { @@ -349,7 +378,7 @@ namespace eval punk::mix::commandset::project { file mkdir $projectdir - puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" + puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" set resultdict [dict create] set antipaths [list\ src/doc/*\ @@ -365,33 +394,45 @@ namespace eval punk::mix::commandset::project { #default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized if {$opt_force} { - puts stdout "copying layout files - with force applied - overwrite all-targets" - set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] + puts stdout "copying layout files - with force applied - overwrite all-targets" + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] } else { - puts stdout "copying layout files - (if source file changed)" - set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] + puts stdout "copying layout files - (if source file changed)" + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] } puts stdout [punkcheck::summarize_install_resultdict $resultdict] - puts stdout "copying layout src/doc files (if target missing)" - set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] + if {[file exists $layout_path/src/doc]} { + puts stdout "copying layout src/doc files (if target missing)" + set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -createdir 1 -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no src/doc in source template - update not required" + } - #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. + #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. #In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. ## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] - set override_antiglob_dir_core [list #* _aside .git] - puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" - set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] + set override_antiglob_dir_core [list #* _aside .git] + if {[file exists $layout_path/.fossil-custom]} { + puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-custom in source template - update not required" + } - puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" - set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] + if {[file exists $layout_path/.fossil-settings]} { + puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-settings in source template - update not required" + } - #scan all files in template + #scan all files in template # - #TODO - deck command to substitute templates? + #TODO - deck command to substitute templates? set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] set stripprefix [file normalize $layout_path] @@ -399,7 +440,7 @@ namespace eval punk::mix::commandset::project { if {[llength $templatefiles]} { puts stdout "Filling template file placeholders with the following tag map:" foreach {placeholder value} $tagmap { - puts stdout " $placeholder -> $value" + puts stdout " $placeholder -> $value" } } foreach templatefullpath $templatefiles { @@ -411,7 +452,7 @@ namespace eval punk::mix::commandset::project { set data2 [string map $tagmap $data] if {$data2 ne $data} { puts stdout "updated template file: $fpath" - set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout + set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout } } else { puts stderr "warning: Missing template file $fpath" @@ -423,7 +464,7 @@ namespace eval punk::mix::commandset::project { if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { - #check if mod-ver.tm file or #modpod-mod-ver folder exist + #check if mod-ver.tm file or #modpod-mod-ver folder exist set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm @@ -441,7 +482,7 @@ namespace eval punk::mix::commandset::project { set overwrite_type zip } else { set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] - set overwrite_type $opt_type + set overwrite_type $opt_type } if {[string tolower $answer] eq "y"} { #REVIEW - all pods zip - for now @@ -462,7 +503,7 @@ namespace eval punk::mix::commandset::project { $installer set_source_target $projectdir/src/doc $projectdir/src/embedded set event [$installer start_event {-install_step kettledoc}] $event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source + $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source #---------- if {\ [llength [dict get [$event targetset_source_changes] changed]]\ @@ -494,7 +535,7 @@ namespace eval punk::mix::commandset::project { if {![punk::repo::is_fossil_root $projectdir]} { set first_fossil 1 - #-k = keep. (only modify the manifest file(s)) + #-k = keep. (only modify the manifest file(s)) if {$is_nested_fossil} { set fossilopen [runx -n {*}$fossil_prog open --nested $repodb_folder/$projectname.fossil -k --workdir $projectdir] } else { @@ -559,11 +600,11 @@ namespace eval punk::mix::commandset::project { #[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied #[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s #[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. - #[para]e.g - #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + #[para]e.g + #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection #[para]Will result in the command being available as projects package require overtype - set db_projects [lib::get_projects $glob] + set db_projects [lib::get_projects $glob] set col1items [lsearch -all -inline -index 0 -subindices $db_projects *] set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] @@ -579,15 +620,15 @@ namespace eval punk::mix::commandset::project { set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] set col3 [string repeat " " $widest3] set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] - - + + append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n append msg [string repeat "=" $tablewidth] \n foreach p $col1items n $col2items c $col3items { append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]" \n - } + } return $msg - #return [list_as_lines [lib::get_projects $glob]] + #return [list_as_lines [lib::get_projects $glob]] } proc detail {{glob {}} args} { package require overtype @@ -599,14 +640,14 @@ namespace eval punk::mix::commandset::project { # -- --- --- --- --- --- --- set opt_description [dict get $opts -description] # -- --- --- --- --- --- --- - - set db_projects [lib::get_projects $glob] + + set db_projects [lib::get_projects $glob] set col1_dbfiles [lsearch -all -inline -index 0 -subindices $db_projects *] set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] set col3items [lmap v $checkouts {llength $v}] - + set col4_pnames [list] set col5_pcodes [list] set col6_dupids [list] @@ -617,13 +658,13 @@ namespace eval punk::mix::commandset::project { set project_name "" set project_code "" set project_desc "" - set db_error "" + set db_error "" if {[file exists $dbfile]} { if {[catch { sqlite3 dbp $dbfile dbp eval {select name,value from config where name like 'project-%';} r { if {$r(name) eq "project-name"} { - set project_name $r(value) + set project_name $r(value) } elseif {$r(name) eq "project-code"} { set project_code $r(value) } elseif {$r(name) eq "project-description"} { @@ -646,7 +687,7 @@ namespace eval punk::mix::commandset::project { } incr file_idx } - + set setid 1 set codeset [dict create] dict for {code dbs} $codes { @@ -655,17 +696,17 @@ namespace eval punk::mix::commandset::project { dict set codeset $code count [llength $dbs] dict set codeset $code seen 0 incr setid - } + } } set dupid 1 foreach pc $col5_pcodes { if {[dict exists $codeset $pc]} { - set seen [dict get $codeset $pc seen] + set seen [dict get $codeset $pc seen] set this_seen [expr {$seen + 1}] dict set codeset $pc seen $this_seen - lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" + lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" } else { - lappend col6_dupids "" + lappend col6_dupids "" } } @@ -691,10 +732,10 @@ namespace eval punk::mix::commandset::project { #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $v}]] set widest7 35 set col7 [string repeat " " $widest7] - - + + set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5 + 1 + $widest6}] - + append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]\ [overtype::left $col4 $title4] [overtype::left $col5 $title5] [overtype::left $col6 $title6]" if {!$opt_description} { @@ -706,7 +747,7 @@ namespace eval punk::mix::commandset::project { append msg [string repeat "=" $tablewidth] \n foreach p $col1_dbfiles n $col2items c $col3items pn $col4_pnames pc $col5_pcodes dup $col6_dupids desc $col7_pdescs { - set desclines [split [textutil::adjust $desc -length $widest7] \n] + set desclines [split [textutil::adjust $desc -length $widest7] \n] set desc1 [lindex $desclines 0] append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]\ [overtype::left $col4 $pn] [overtype::left $col5 $pc] [overtype::left $col6 $dup]" @@ -715,20 +756,20 @@ namespace eval punk::mix::commandset::project { } else { append msg " [overtype::left $col7 $desc1]" \n foreach dline [lrange $desclines 1 end] { - append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n + append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n } } - } - return $msg - #return [list_as_lines [lib::get_projects $glob]] + } + return $msg + #return [list_as_lines [lib::get_projects $glob]] } proc cd {{glob {}} args} { dict set args -cd 1 - work $glob {*}$args + work $glob {*}$args } proc work {{glob {}} args} { package require sqlite3 - set db_projects [lib::get_projects $glob] + set db_projects [lib::get_projects $glob] if {[llength $db_projects] == 0} { puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$glob'" return "" @@ -738,22 +779,22 @@ namespace eval punk::mix::commandset::project { set defaults [dict create\ -cd 0\ -detail "\uFFFF"\ - ] + ] set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set opt_cd [dict get $opts -cd] - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set opt_detail [dict get $opts -detail] set opt_detail_explicit_zero 1 ;#default assumption only if {$opt_detail eq "\uFFFF"} { set opt_detail_explicit_zero 0 set opt_detail 0; #default } - # -- --- --- --- --- --- --- + # -- --- --- --- --- --- --- set workdir_dict [dict create] set all_workdirs [list] foreach pinfo $db_projects { - lassign $pinfo fosdb name workdirs + lassign $pinfo fosdb name workdirs foreach wdir $workdirs { dict set workdir_dict $wdir $pinfo lappend all_workdirs $wdir @@ -767,15 +808,15 @@ namespace eval punk::mix::commandset::project { set col_pcodes [list] set col_dupids [list] - set fosdb_count [dict create] + set fosdb_count [dict create] set fosdb_dupset [dict create] set fosdb_cache [dict create] set dupset 0 set rowid 1 foreach wd $workdirs { set wdinfo [dict get $workdir_dict $wd] - lassign $wdinfo fosdb nm siblingworkdirs - dict incr fosdb_count $fosdb + lassign $wdinfo fosdb nm siblingworkdirs + dict incr fosdb_count $fosdb set dbcount [dict get $fosdb_count $fosdb] if {[llength $siblingworkdirs] > 1} { if {![dict exists $fosdb_dupset $fosdb]} { @@ -784,7 +825,7 @@ namespace eval punk::mix::commandset::project { } set dupid "[dict get $fosdb_dupset $fosdb].$dbcount/[llength $siblingworkdirs]" } else { - set dupid "" + set dupid "" } if {$dbcount == 1} { set pname "" @@ -801,7 +842,7 @@ namespace eval punk::mix::commandset::project { puts stderr "!!! error: $errM" } } else { - puts stderr "!!! missing fossil db $fosdb" + puts stderr "!!! missing fossil db $fosdb" } } else { set info [dict get $fosdb_cache $fosdb] @@ -817,7 +858,7 @@ namespace eval punk::mix::commandset::project { set col_states [list] set state_title "" - #if only one set of fossil checkouts in the resultset and opt_detail is 0 and not explicit - retrieve workingdir state for each co + #if only one set of fossil checkouts in the resultset and opt_detail is 0 and not explicit - retrieve workingdir state for each co if {([llength [dict keys $fosdb_cache]] == 1)} { if {!$opt_detail_explicit_zero} { set opt_detail 1 @@ -843,13 +884,13 @@ namespace eval punk::mix::commandset::project { set state_dict [punk::repo::workingdir_state_summary_dict $wd_state] lappend c_rev [string range [dict get $state_dict revision] 0 9] lappend c_rev_iso [dict get $state_dict revision_iso8601] - lappend c_unchanged [dict get $state_dict unchanged] + lappend c_unchanged [dict get $state_dict unchanged] lappend c_changed [dict get $state_dict changed] lappend c_new [dict get $state_dict new] lappend c_missing [dict get $state_dict missing] lappend c_extra [dict get $state_dict extra] puts -nonewline stderr "." - } + } puts -nonewline stderr \n set t0 "Revision" set w0 [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev] {string length $v}]] @@ -872,13 +913,13 @@ namespace eval punk::mix::commandset::project { set t5 "Extr" set w5 [tcl::mathfunc::max {*}[lmap v [concat [list $t5] $c_extra] {string length $v}]] set c5 [string repeat " " $w5] - + set state_title "[overtype::left $c0 $t0] [overtype::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [overtype::right $c1 $u] [overtype::right $c2 $c] [overtype::right $c3 $n] [overtype::right $c4 $m] [overtype::right $c5 $e]" } } - + set msg "" if {$opt_cd} { set title0 "CD" @@ -907,7 +948,7 @@ namespace eval punk::mix::commandset::project { append msg "[overtype::right $col0 $title0] [overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3] [overtype::left $col4 $title4] [overtype::left $col5 $title5]" if {[llength $col_states]} { - set title6 $state_title + set title6 $state_title set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col_states] {string length $v}]] set col6 [string repeat " " $widest6] incr tablewidth [expr {$widest6 + 1}] @@ -919,12 +960,20 @@ namespace eval punk::mix::commandset::project { if {[llength $col_states]} { foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes s $col_states { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode] [overtype::left $col6 $s]" \n - } + } } else { foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode]" \n - } + } } set numrows [llength $col_rowids] if {$opt_cd && $numrows >= 1} { @@ -936,7 +985,7 @@ namespace eval punk::mix::commandset::project { ::cd $workingdir return $workingdir } else { - puts stderr "path $workingdir doesn't appear to exist" + puts stderr "path $workingdir doesn't appear to exist" return [pwd] } } else { @@ -955,12 +1004,12 @@ namespace eval punk::mix::commandset::project { #*** !doctools #[list_end] [comment {-- end collection namespace definitions --}] } - + namespace eval lib { proc template_tag {tagname} { #todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. #we need to detect presence of tags intended for punk::mix system - #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run + #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run return [string cat % $tagname %] } #get project info only by opening the central confg-db @@ -983,12 +1032,13 @@ namespace eval punk::mix::commandset::project { set path [string trim [string range $pr 5 end]] set nm [file rootname [file tail $path]] set ckouts [fosconf eval {select name from global_config where value = $path;}] + #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" set checkout_paths [list] #strip "ckout:" foreach ck $ckouts { lappend checkout_paths [string trim [string range $ck 6 end]] } - lappend paths_and_names [list $path $nm $checkout_paths] + lappend paths_and_names [list $path $nm $checkout_paths] } set filtered_list [list] foreach glob $globlist { @@ -996,16 +1046,14 @@ namespace eval punk::mix::commandset::project { foreach m $matches { if {$m ni $filtered_list} { lappend filtered_list $m - } + } } } set projects [lsort -index 1 $filtered_list] return $projects } - + } - - @@ -1018,15 +1066,10 @@ namespace eval punk::mix::commandset::project { - - - - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { 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/punk/mix/commandset/repo-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm index 2b3ca282..277e386e 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm @@ -24,7 +24,11 @@ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::mix::commandset::repo { namespace export * + + variable PUNKARGS + proc tickets {{project ""}} { + #todo set result "" if {[string length $project]} { puts stderr "project status unimplemented" @@ -51,9 +55,9 @@ namespace eval punk::mix::commandset::repo { set repopaths [punk::repo::find_repos [pwd]] set repos [dict get $repopaths repos] if {![llength $repos]} { - append result [dict get $repopaths warnings] + append result [a+ bold yellow][dict get $repopaths warnings][a] } else { - append result [dict get $repopaths warnings] + append result [a+ bold yellow][dict get $repopaths warnings][a] lassign [lindex $repos 0] repopath repotypes if {"fossil" in $repotypes} { append result \n "Fossil repo based at $repopath" @@ -68,6 +72,17 @@ namespace eval punk::mix::commandset::repo { } return $result } + + #punk::args + lappend PUNKARGS [list { + @id -id ::punk::mix::commandset::repo::fossil-move-repository + @cmd -name punk::mix::commandset::repo::fossil-move-repository -help\ + "Move the fossil repository file (usually named with .fossil extension). + This is an interactive function which will prompt for answers on stdin + before proceeding. + The move can be done even if there are open checkouts and will maintain + the link between checkout databases and the repository file." + }] proc fossil-move-repository {{path ""}} { set searchbase [pwd] set projectinfo [punk::repo::find_repos $searchbase] @@ -280,7 +295,7 @@ namespace eval punk::mix::commandset::repo { set ckouts [oldrepo eval {select name from config where name like 'ckout:%'}] oldrepo close if {[llength $ckouts] > 1} { - puts stdout "There are [llength $ckouts] checkouts for the repository you are moving" + puts stdout "There are [llength $ckouts] checkouts for the repository you are moving" puts stdout "You will be asked for each checkout if you want to adjust it to point to $target_repodb_folder/$pname2.folder" } set original_cwd [pwd] @@ -303,11 +318,11 @@ namespace eval punk::mix::commandset::repo { puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" puts stderr "$moveresult" } else { - puts stdout "OK - move performed with result:" + puts stdout "OK - move performed with result:" puts stdout $moveresult } } - } + } cd $original_cwd } @@ -378,7 +393,7 @@ namespace eval punk::mix::commandset::repo { puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" puts stderr "$moveresult" } else { - puts stdout "OK - move performed with result:" + puts stdout "OK - move performed with result:" puts stdout $moveresult } } @@ -401,10 +416,10 @@ namespace eval punk::mix::commandset::repo { - - - - +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::mix::commandset::repo +} @@ -412,9 +427,9 @@ namespace eval punk::mix::commandset::repo { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { 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/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index c61db428..98f171c7 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -1,5 +1,5 @@ # -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev 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. @@ -13,19 +13,70 @@ # @@ Meta End +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_scriptwrap 0 0.1.0] +#[copyright "2024"] +#[titledesc {scriptwrap polyglot tool}] [comment {-- Name section and table of contents description --}] +#[moddesc {scriptwrap tool}] [comment {-- Description at end of page heading --}] +#[require punk::mix::commandset::scriptwrap] +#[keywords module commandset launcher scriptwrap] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of scriptwrap +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by poshinfo +#[list_begin itemized] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements ##e.g package require frobz +package require punk::lib +package require punk::args package require punk::mix package require punk::mix::base package require punk::fileline +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::lib}] +#[item] [package {punk::args}] +#[item] [package {punk::mix}] +#[item] [package {punk::base}] +#[item] [package {punk::fileline}] + +#*** !doctools +#[list_end] + +#*** !doctools +#[section API] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + namespace eval punk::mix::commandset::scriptwrap { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::scriptwrap}] + #[para] Core API functions for punk::mix::commandset::scriptwrap + #[list_begin definitions] + namespace export * namespace eval fileline { @@ -1192,23 +1243,34 @@ namespace eval punk::mix::commandset::scriptwrap { return $result } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap ---}] namespace eval lib { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] + #[para] Library API functions for punk::mix::commandset::scriptwrap + #[list_begin definitions] proc get_wrapper_folders {args} { set argd [punk::args::get_dict { #*** !doctools #[call [fun get_wrapper_folders] [arg args] ] - #[para] Return list of dicts representing wrapper folders. keys: basefolder sourceinfo + #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo #[para] Arguments: # [list_begin arguments] # [arg_def string args] name-value pairs -scriptpath # [list_end] - *proc -name get_wrapper_folders - *opts -anyopts 0 - -scriptpath -default "" - *values -minvalues 0 -maxvalues 0 + @id -id ::punk::mix::commandset::scriptwrap + @cmd -name punk::mix::commandset::get_wrapper_folders + + @opts -anyopts 0 + -scriptpath -default "" -type directory\ + -help "" + #todo -help folder within a punk.templates provided area??? + + @values -minvalues 0 -maxvalues 0 } $args] # -- --- --- --- --- --- --- --- --- @@ -1377,11 +1439,16 @@ namespace eval punk::mix::commandset::scriptwrap { return [dict create ok $status linecount [llength $lines] data $tags errors $errors] } - + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap::lib ---}] } namespace eval batchlib { - # + #*** !doctools + #[subsection {Namespace punk::mix::commandset::scriptwrap::batchlib}] + #[para] Utility funcions for processing windows .bat files + #[list_begin definitions] + #see also: https://www.dostips.com/forum/viewtopic.php?t=3803 'Rules for label names vs GOTO and CALL # review - we may need different get_callsite_label functions? @@ -1647,23 +1714,13 @@ namespace eval punk::mix::commandset::scriptwrap { #return rawlabel so we can see it as it appears in the data - as opposed to how it is interpreted as a label by cmd.exe return [list labelfound 1 label $label rawlabel $rawlabel] } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap::batchlib ---}] } } - - - - - - - - - - - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::commandset::scriptwrap { @@ -1671,3 +1728,6 @@ package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::com set version 0.1.0 }] return + +#*** !doctools +#[manpage_end] \ No newline at end of file diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm index dab5312f..63b5335c 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm @@ -47,7 +47,7 @@ namespace eval punk::mix::templates { lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. #review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. - #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. + #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. return $decls } } @@ -86,9 +86,9 @@ namespace eval punk::mix::templates { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::templates [namespace eval punk::mix::templates { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip new file mode 100644 index 0000000000000000000000000000000000000000..665234dec0d8e52074344321c6b9813e78b18ed9 GIT binary patch literal 1275 zcmWIWW@Zs#00D&^uOh$k`3i4BQfmCTus%}|oQE_H|o_+vS69>b~ZLcCS zZ!j;O&&0s6osEG(7q=#uSvmQMDaFY}nFS?!CCNFpAqVqr8}RHEe_>zXyMZbC_L}Vn zwX5!AGMAmNNl;Y_)AnAcqW-q&&uPG1=Nxnl~O^07{emEb@ zpg-r8Q~SckuWp%4$+6v0f0ZM&H*d6DxK7w5_rZp52Q@dhiZy3E$hjDGGqQ4}?x`t% zo@#N_PW#EE#d|t%*}8sD`@dq}Yi~Q=XOvp7{DHudq6L}mR$Xs7F9^N~&6vX2vQxrk z>S~t=pRMN?FFcXHVd=~LnXbVm-fvDgZhUzm=jGIy{T&aiCrmW`6XB4-(PG+TFflcG zYf8{l#YIoLCraB@`);3ZzNT_EmnBo?`QTqCuEhL}6}P+_DXk`^ws`I49Gk9b%h#Ug zxSuJSF!Rf6!;?n!&2MtoPUW}Uu(2<|WWm)~Epv|8(1mMPDZX5*={H+DH76%|m!tB* zi+e-UZm?Ly&pj;5`NlRm$J=r16U9;?r78a(7@O=+&bTV<`Gb3Y;?yOlrPNP0mdyOS zE^C3i1oImm-}=Z`e~yLEI%8(S8giXSI(*lf(s|Q9#jM!&`%=GQ_O+vHLMz-CD#g|B zZA;v{Or^Z6q)Y0;6Z z0io;Xwfbip+Hkb<9cA7m=-$7#h$ZuK|70~oli2X7A@f3cIt^k^clIB;X}LRi((EIu zdg`Ue&mSz7VtgC0yyeG@x$|Tq-?&y!9|M?LqJ#cQI@js92+iZX-+!lx>@uc*s;Ifn9Cr;}JYIvPJtM47EagyQD zq9bSKoY_;-`ef1~nY&u8PkN3lI`U-F6{XfKi~htcm~known at $i : [lindex $args $i]" - if {($i % 2) != 0} { + if {$i % 2} { error "unexpected option at index $i. known options: $knownopts must come in -opt val pairs." } incr i set last_opt $i } else { - set last_opt [expr {$i - 1}] + set last_opt [expr {$i - 1}] break } } @@ -73,7 +73,7 @@ namespace eval punk::mix::util { #puts stderr "opts: $opts paths: $paths" - #let's proceed, but warn the user if an apparent option is in paths + #let's proceed, but warn the user if an apparent option is in paths foreach opt [list -encoding -eofchar -translation] { if {$opt in $paths} { puts stderr "fcat WARNING: apparent option $opt found after file argument(s) (expected them before filenames). Passing to fileutil::cat anyway - but for at least some versions, these options may be ignored. commandline 'fcat $args'" @@ -142,7 +142,7 @@ namespace eval punk::mix::util { } #---------------------------------------- - #namespace import ::punk::ns::nsimport_noclobber + #namespace import ::punk::ns::nsimport_noclobber proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { set source_ns [namespace qualifiers $pattern] @@ -153,7 +153,7 @@ namespace eval punk::mix::util { set nscaller [uplevel 1 {namespace current}] set ns [punk::nsjoin $nscaller $ns] } - set a_export_patterns [namespace eval $source_ns {namespace export}] + set a_export_patterns [namespace eval $source_ns {namespace export}] set a_commands [info commands $pattern] set a_tails [lmap v $a_commands {namespace tail $v}] set a_exported_tails [list] @@ -261,6 +261,8 @@ namespace eval punk::mix::util { return } + # review punk::lib::tm_version.. functions + proc is_valid_tm_version {versionpart} { #Needs to be suitable for use with Tcl's 'package vcompare' if {![catch [list package vcompare $versionpart $versionpart]]} { @@ -357,9 +359,9 @@ namespace eval punk::mix::util { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::util [namespace eval punk::mix::util { 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/punk/mod-0.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mod-0.1.tm new file mode 100644 index 00000000..58906c88 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mod-0.1.tm @@ -0,0 +1,164 @@ +#punkapps app manager +# deck cli + +namespace eval punk::mod::cli { + namespace export help list run + namespace ensemble create + + # namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown + if 0 { + proc _unknown {ns args} { + puts stderr "punk::mod::cli::_unknown '$ns' '$args'" + puts stderr "punk::mod::cli::help $args" + puts stderr "arglen:[llength $args]" + punk::mod::cli::help {*}$args + } + } + + #cli must have _init method - usually used to load commandsets lazily + # + variable initialised 0 + proc _init {args} { + variable initialised + if {$initialised} { + return + } + #... + set initialised 1 + } + + proc help {args} { + set basehelp [punk::mix::base help {*}$args] + #namespace export + return $basehelp + } + proc getraw {appname} { + upvar ::punk::config::running running_config + set app_folders [dict get $running_config apps] + #todo search each app folder + set bases [::list] + set versions [::list] + set mains [::list] + set appinfo [::list bases {} mains {} versions {}] + + foreach containerfolder $app_folders { + lappend bases $containerfolder + if {[file exists $containerfolder]} { + if {[file exists $containerfolder/$appname/main.tcl]} { + #exact match - only return info for the exact one specified + set namematches $appname + set parts [split $appname -] + } else { + set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + } + foreach nm $namematches { + set mainfile $containerfolder/$nm/main.tcl + set parts [split $nm -] + if {[llength $parts] == 1} { + set ver "" + } else { + set ver [lindex $parts end] + } + if {$ver ni $versions} { + lappend versions $ver + lappend mains $ver $mainfile + } else { + puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" + } + } + } else { + puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" + } + } + dict set appinfo versions $versions + #todo - natsort! + set sorted_versions [lsort $versions] + set latest [lindex $sorted_versions 0] + if {$latest eq "" && [llength $sorted_versions] > 1} { + set latest [lindex $sorted_versions 1 + } + dict set appinfo latest $latest + + dict set appinfo bases $bases + dict set appinfo mains $mains + return $appinfo + } + + proc list {{glob *}} { + upvar ::punk::config::running running_config + set apps_folder [dict get $running_config apps] + if {[file exists $apps_folder]} { + if {[file exists $apps_folder/$glob]} { + #tailcall source $apps_folder/$glob/main.tcl + return $glob + } + set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] + if {[llength $apps] == 0} { + if {[string first * $glob] <0 && [string first ? $glob] <0} { + #no glob chars supplied - only launch if exact match for name part + set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] + set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? + if {[llength $namematches] > 0} { + set latest [lindex $namematches end] + lassign $latest nm ver + #tailcall source $apps_folder/$latest/main.tcl + } + } + } + + return $apps + } + } + + #todo - way to launch as separate process + # solo-opts only before appname - args following appname are passed to the app + proc run {args} { + set nameposn [lsearch -not $args -*] + if {$nameposn < 0} { + error "punkapp::run unable to determine application name" + } + set appname [lindex $args $nameposn] + set controlargs [lrange $args 0 $nameposn-1] + set appargs [lrange $args $nameposn+1 end] + + set appinfo [punk::mod::cli::getraw $appname] + if {[llength [dict get $appinfo versions]]} { + set ver [dict get $appinfo latest] + puts stdout "info: $appinfo" + set ::argc [llength $appargs] + set ::argv $appargs + source [dict get $appinfo mains $ver] + if {"-hideconsole" in $controlargs} { + puts stderr "attempting console hide" + #todo - something better - a callback when window mapped? + after 500 {::punkapp::hide_console} + } + return $appinfo + } else { + error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" + } + } + + +} + +namespace eval punk::mod::cli { + proc _cli {args} { + #don't use tailcall - base uses info level to determine caller + ::punk::mix::base::_cli {*}$args + } + variable default_command help + package require punk::mix::base + package require punk::overlay + punk::overlay::custom_from_base [namespace current] ::punk::mix::base +} + +package provide punk::mod [namespace eval punk::mod { + variable version + set version 0.1 + +}] + + + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm new file mode 100644 index 00000000..bce44dee --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -0,0 +1,1491 @@ +# -*- 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) 2024 +# +# @@ Meta Begin +# Application punk::nav::fs 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::nav::fs 0 0.1.0] +#[copyright "2024"] +#[titledesc {punk::nav::fs console filesystem navigation}] [comment {-- Name section and table of contents description --}] +#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] +#[require punk::nav::fs] +#[keywords module filesystem terminal] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::nav::fs +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::nav::fs +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::lib +package require punk::args +package require punk::ansi +package require punk::winpath +package require punk::du +package require commandstack +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::lib}] +#[item] [package {punk::args}] +#[item] [package {punk::winpath}] +#[item] [package {punk::du}] +#[item] [package {punk::commandstack}] + +if {"windows" eq $::tcl_platform(platform)} { + catch {package require punk::unixywindows} +} +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::nav::fs::class { + #*** !doctools + #[subsection {Namespace punk::nav::fs::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::nav::fs { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + + #Both tcl's notion of pwd and VIRTUAL_CWD can be out of sync with the process CWD. This happens when in a VFS. + #We can also have VIRTUAL_CWD navigate to spaces that Tcl's cd can't - review + + variable VIRTUAL_CWD ;#cwd that tracks pwd except when in zipfs locations that are not at or below a mountpoint + if {![interp issafe]} { + set VIRTUAL_CWD [pwd] + } else { + set VIRTUAL_CWD "" + } + proc vwd {} { + variable VIRTUAL_CWD + set cwd [pwd] + if {$cwd ne $VIRTUAL_CWD} { + puts stderr "pwd: $cwd" + } + return $::punk::nav::fs::VIRTUAL_CWD + } + + #TODO - maintain per 'volume/server' CWD + #e.g cd and ./ to: + # d: + # //zipfs: + # //server + # https://example.com + # should return to the last CWD for that volume/server + + #VIRTUAL_CWD follows pwd when changed via cd + set stackrecord [commandstack::rename_command -renamer punk::nav::fs cd {args} { + if {![catch { + $COMMANDSTACKNEXT {*}$args + } errM]} { + set ::punk::nav::fs::VIRTUAL_CWD [pwd] + } else { + error $errM + } + }] + + #*** !doctools + #[subsection {Namespace punk::nav::fs}] + #[para] Core API functions for punk::nav::fs + #[list_begin definitions] + + + #NOTE - as we expect to run other apps (e.g Tk) in the same process, but possibly different threads - we should be careful about use of cd which is per-process not per-thread. + #As this function recurses and calls cd multiple times - it's not thread-safe. + #Another thread could theoretically cd whilst this is running. + #Most likely this will then just error-out - but there is a possibility we could end up in the wrong directory, or cause the same problems in the other thread. + #REVIEW - consider looking at current directory only at the beginning and do a single cd to an absolute path. + #currently this allows ./ subdir subdir2 nonexistant and we cd to subdir/subdir2 even though an error is produced at the end. + #This offers a convenience for repl useage at the slight cost of more potential cross-thread cd interference + #- although presumably most library code shouldn't be changing CWD anyway. + #Ideally the user/repl should be in control of the processes working directory and we shouldn't have to worry too much here. + #Notably for example tcltest-2.5.5 at least uses cd - so this is something that may be best run in a separate process (for each test suite?) + #This seems unfortunate - as a multithreaded set of test runs might otherwise have made some sense.. but perhaps for tests more serious isolation is a good idea. + #It also seems common to cd when loading certain packages e.g tls from starkit. + #While in most/normal cases the library will cd back to the remembered working directory after only a brief time - there seem to be many opportunities for issues + #if the repl is used to launch/run a number of things in the one process + proc d/ {args} { + variable VIRTUAL_CWD + + set is_win [expr {"windows" eq $::tcl_platform(platform)}] + + set repl_runid 0 + if {[info commands ::punk::get_repl_runid] ne ""} { + set repl_runid [punk::get_repl_runid] + } + #set ::punk::last_run_display [list] + + if {([llength $args]) && ([lindex $args 0] eq "")} { + set args [lrange $args 1 end] + } + + + if {![llength $args]} { + #ls is too slow even over a fairly low-latency network + #set out [runout -n ls -aFC] + if {[string match //zipfs:/* $VIRTUAL_CWD]} { + if {[Zipfs_path_within_zipfs_mounts $VIRTUAL_CWD]} { + if {[pwd] ne $VIRTUAL_CWD} { + commandstack::basecall cd $VIRTUAL_CWD + } + } + set matchinfo [dirfiles_dict -searchbase $VIRTUAL_CWD -with_times {f d l} -with_sizes {f d l}] + } else { + if {[pwd] ne $VIRTUAL_CWD} { + commandstack::basecall cd $VIRTUAL_CWD + } + set matchinfo [dirfiles_dict -searchbase [pwd] -with_times {f d l} -with_sizes {f d l}] + } + set dircount [llength [dict get $matchinfo dirs]] + set filecount [llength [dict get $matchinfo files]] + set symlinkcount [llength [dict get $matchinfo links]] ;#doesn't include windows shelllinks (.lnk) + #set location [file normalize [dict get $matchinfo location]] + set location [dict get $matchinfo location] + + + #result for glob is count of matches - use dirfiles etc for script access to results + set result [list location $location dircount $dircount filecount $filecount symlinks $symlinkcount] + set filesizes [dict get $matchinfo filesizes] + if {[llength $filesizes]} { + set filesizes [lsearch -all -inline -not $filesizes na] + set filebytes [tcl::mathop::+ {*}$filesizes] + lappend result filebytes [punk::lib::format_number $filebytes] + } + if {[punk::nav::fs::system::codethread_is_running]} { + if {[llength [info commands ::punk::console::titleset]]} { + #if ansi is off - punk::console::titleset will try 'local' api method - which can fail + catch {::punk::console::titleset [lrange $result 1 end]} + } + } + if {[string match //zipfs:/* $location]} { + set stripbase 0 + } else { + set stripbase 1 + } + set out [dirfiles_dict_as_lines -stripbase $stripbase $matchinfo] + set chunklist [list] + lappend chunklist [list stdout "[punk::ansi::a+ brightwhite]$out[punk::ansi::a]\n"] + if {[file normalize $VIRTUAL_CWD] ne [pwd]} { + lappend chunklist [list stderr "[punk::ansi::a+ red]PWD:[pwd] VIRTUAL_CWD:$VIRTUAL_CWD[punk::ansi::a]"] + } + lappend chunklist [list result $result] + if {$repl_runid != 0} { + if {![tsv::llength repl runchunks-$repl_runid]} { + #set ::punk::last_run_display $chunklist + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } + } else { + punk::nav::fs::system::emit_chunklist $chunklist + } + #puts stdout "-->[ansistring VIEW $result]" + return $result + } else { + set atail [lassign $args a1] + if {[llength $args] == 1} { + set a1 [lindex $args 0] + switch -exact -- $a1 { + . - ./ { + tailcall punk::nav::fs::d/ + } + .. - ../ { + if {$VIRTUAL_CWD eq "//zipfs:/" && ![string match //zipfs:/* [pwd]]} { + #exit back to last nonzipfs path that was in use + set VIRTUAL_CWD [pwd] + tailcall punk::nav::fs::d/ + } + + #we need to use normjoin to allow navigation to //server instead of just to //server/share (//server browsing unimplemented - review) + # [file join //server ..] would become /server/.. - use normjoin to get //server + # file dirname //server/share would stay as //server/share + #set up1 [file dirname $VIRTUAL_CWD] + set up1 [punk::path::normjoin $VIRTUAL_CWD ..] + if {[string match //zipfs:/* $up1]} { + if {[Zipfs_path_within_zipfs_mounts $up1]} { + cd $up1 + set VIRTUAL_CWD $up1 + } else { + set VIRTUAL_CWD $up1 + } + } else { + cd $up1 + #set VIRTUAL_CWD [file normalize $a1] + } + tailcall punk::nav::fs::d/ + } + } + + if {![regexp {[*?]} $a1] && [file pathtype $a1] ne "relative"} { + #non-relative non-glob + if { ![string match //zipfs:/* $a1]} { + if {[file type $a1] eq "directory"} { + cd $a1 + #set VIRTUAL_CWD $a1 + tailcall punk::nav::fs::d/ + } + } + } + + + if {![regexp {[*?]} $a1] && ![string match //zipfs:/* $a1] && ![string match "//zipfs:/*" $VIRTUAL_CWD]} { + if {[file type $a1] eq "directory"} { + cd $a1 + #set VIRTUAL_CWD [file normalize $a1] + tailcall punk::nav::fs::d/ + } + } + + if {![regexp {[*?]} $a1]} { + #NON-Glob target + #review + if {[string match //zipfs:/* $a1]} { + if {[Zipfs_path_within_zipfs_mounts $a1]} { + commandstack::basecall cd $a1 + } + set VIRTUAL_CWD $a1 + set curdir $a1 + } else { + set target [punk::path::normjoin $VIRTUAL_CWD $a1] + if {[string match //zipfs:/* $VIRTUAL_CWD]} { + if {[Zipfs_path_within_zipfs_mounts $target]} { + commandstack::basecall cd $target + } + } + if {[file type $target] eq "directory"} { + set VIRTUAL_CWD $target + } + } + tailcall punk::nav::fs::d/ + } + set curdir $VIRTUAL_CWD + } else { + set curdir [pwd] + } + + + #globchar somewhere in path - treated as literals except in final segment (for now. todo - make more like ns/ which accepts full path globbing with double ** etc.) + + set searchspec [lindex $args 0] + + set result "" + set chunklist [list] + + #Only merge results if location matches previous (caller can deliberately intersperse bogus globs to force split if desired) + #TODO - remove duplicate file or dir items for overlapping patterns in same location!!! (at least for count, filebyte totals if not for display) + set last_location "" + set this_result [dict create] + foreach searchspec $args { + set path [path_to_absolute $searchspec $curdir $::tcl_platform(platform)] + set has_tailglob [expr {[regexp {[?*]} [file tail $path]]}] + #we have already done a 'cd' if only one unglobbed path was supplied - therefore any remaining non-glob tails must be tested for folderness vs fileness to see what they mean + #this may be slightly surprising if user tries to exactly match both a directory name and a file both as single objects; because the dir will be listed (auto /* applied to it) - but is consistent enough. + #lower level dirfiles or dirfiles_dict can be used to more precisely craft searches. ( d/ will treat dir the same as dir/*) + + set searchspec_relative [expr {[file pathtype $searchspec] eq "relative"}] + if {$has_tailglob} { + set location [file dirname $path] + set glob [file tail $path] + if {$searchspec_relative} { + set searchbase [pwd] + } else { + set searchbase [file dirname $searchspec] + } + } else { + if {[string match //zipfs:/* $path]} { + set location $path + set glob * + set searchbase $path + } elseif {[file isdirectory $path]} { + set location $path + set glob * + if {$searchspec_relative} { + set searchbase [pwd] + } else { + set searchbase $path + } + } else { + set location [file dirname $path] + set glob [file tail $path] ;#search for exact match file + if {$searchspec_relative} { + set searchbase [pwd] + } else { + set searchbase [file dirname $path] + } + } + } + set matchinfo [dirfiles_dict -searchbase $searchbase -tailglob $glob -with_sizes {f d l} -with_times {f d l} $location] + #puts stderr "=--->$matchinfo" + + + set location [file normalize [dict get $matchinfo location]] + if {[string match //xzipfs:/* $location] || $location ne $last_location} { + #REVIEW - zipfs test disabled with leading x + #emit previous result + if {[dict size $this_result]} { + dict set this_result filebytes [punk::lib::format_number [dict get $this_result filebytes]] + lappend chunklist [list result $this_result] + if {$result ne ""} { + append result \n + } + append result $this_result + } + set this_result [dict create] + set dircount 0 + set filecount 0 + } + incr dircount [llength [dict get $matchinfo dirs]] + incr filecount [llength [dict get $matchinfo files]] + + #result for glob is count of matches - use dirfiles etc for script access to results + dict set this_result location $location + dict set this_result dircount $dircount + dict set this_result filecount $filecount + + set filesizes [dict get $matchinfo filesizes] + if {[llength $filesizes]} { + set filesizes [lsearch -all -inline -not $filesizes na] + set filebytes [tcl::mathop::+ {*}$filesizes] + dict incr this_result filebytes $filebytes + } else { + dict incr this_result filebytes 0 ;#ensure key exists! + } + dict lappend this_result pattern [dict get $matchinfo opts -glob] + + if {[string match //zipfs:/* $location]} { + set stripbase 0 + } else { + set stripbase 1 + } + set out [dirfiles_dict_as_lines -stripbase $stripbase $matchinfo] + + lappend chunklist [list stdout "[punk::ansi::a+ brightwhite]$out[punk::ansi::a]\n"] + + set last_location $location + } + #process final result + if {[dict size $this_result]} { + dict set this_result filebytes [punk::lib::format_number [dict get $this_result filebytes]] + lappend chunklist [list result $this_result] + if {$result ne ""} { + append result \n + } + append result $this_result + } + if {[file normalize $VIRTUAL_CWD] ne [pwd]} { + lappend chunklist [list stderr "[punk::ansi::a+ red]PWD:[pwd] VIRTUAL_CWD:$VIRTUAL_CWD[punk::ansi::a]"] + } + + + if {[punk::nav::fs::system::codethread_is_running]} { + if {![tsv::llength repl runchunks-$repl_runid]} { + #set ::punk::last_run_display $chunklist + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } + } + if {$repl_runid == 0} { + punk::nav::fs::system::emit_chunklist $chunklist + } + return $result + } + } + + proc dd/ {args} { + #set ::punk::last_run_display [list] + set repl_runid 0 + if {[info commands ::punk::get_repl_runid] ne ""} { + set repl_runid [punk::get_repl_runid] + } + if {![llength $args]} { + set path .. + } else { + set path ../[file join {*}$args] + } + set normpath [file normalize $path] + cd $normpath + set matchinfo [dirfiles_dict -searchbase $normpath -with_sizes {f d l} -with_times {f d l} $normpath] + set dircount [llength [dict get $matchinfo dirs]] + set filecount [llength [dict get $matchinfo files]] + set location [file normalize [dict get $matchinfo location]] + #result for glob is count of matches - use dirfiles etc for script access to results + set result [list location $location dircount $dircount filecount $filecount] + set filesizes [dict get $matchinfo filesizes] + if {[llength $filesizes]} { + set filesizes [lsearch -all -inline -not $filesizes na] + set filebytes [tcl::mathop::+ {*}$filesizes] + lappend result filebytes [punk::lib::format_number $filebytes] + } + + set out [dirfiles_dict_as_lines -stripbase 1 $matchinfo] + #return $out\n[pwd] + set chunklist [list] + lappend chunklist [list stdout "[punk::ansi::a+ brightwhite]$out[punk::ansi::a]\n"] + lappend chunklist [list result $result] + + if {[punk::nav::fs::system::codethread_is_running]} { + if {![tsv::llength repl runchunks-$repl_runid]} { + #set ::punk::last_run_display $chunklist + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } + if {[llength [info commands ::punk::console::titleset]]} { + catch {::punk::console::titleset [lrange $result 1 end]} ;#strip location key + } + } + if {$repl_runid == 0} { + punk::nav::fs::system::emit_chunklist $chunklist + } + return $result + } + + proc d/new {args} { + if {![llength $args]} { + error "usage: d/new

\[ ...\]" + } + set a1 [lindex $args 0] + set curdir [pwd] + set path1 [path_to_absolute $a1 $curdir $::tcl_platform(platform)] + set fullpath [file join $path1 {*}[lrange $args 1 end]] + + if {[file exists $fullpath]} { + error "Folder $fullpath already exists" + } + file mkdir $fullpath + d/ $fullpath + } + + #todo use unknown to allow d/~c:/etc ?? + proc d/~ {args} { + set home $::env(HOME) + set target [file join $home {*}$args] + if {![file isdirectory $target]} { + error "Folder $target not found" + } + d/ $target + } + + + #run a file + proc x/ {args} { + if {![llength $args]} { + set result [d/] + append result \n "x/ ?args?" + return $result + } + set curdir [pwd] + #todo - allow wish for those who want it.. but in punk we try to use tclsh or a kit and load Tk as a library + set scriptconfig [dict create\ + tcl [list exe tclsh extensions [list ".tcl" ".tm" ".tk" ".kit"]]\ + python [list exe python extensions [list ".py"]]\ + lua [list exe lua extensions [list ".lua"]]\ + perl [list exe perl extensions [list ".pl"]]\ + php [list exe php extensions [list ".php"]]\ + ] + set tcl_extensions [list ".tcl" ".tm" ".kit" ".tk"] ;#todo - load from config + set py_extensions [list ".py"] + set lua_extensions [list ".lua"] + set perl_extensions [list ".pl"] + + set script_extensions [list] + set extension_lookup [dict create] + tcl::dict::for {lang langinfo} $scriptconfig { + set extensions [dict get $langinfo extensions] + lappend script_extensions {*}$extensions + foreach e $extensions { + dict set extension_lookup $e $lang ;#provide reverse lookup + } + } + + #some executables (e.g tcl) can use arguments prior to the script + #use first entry on commandline for which a file exists *and has a script extension - or is executable* as the script to run + #we can't always just assume that first existant file on commandline is the one being run, as it might be config file + #e.g php -c php.ini -f script.php + set scriptlang "" + set scriptfile "" + foreach a $args { + set ext [file extension $a] + if {$ext in $script_extensions && [file exists $a]} { + set scriptlang [dict get $extension_lookup $ext] + set scriptfile $a + break + } + } + puts "scriptlang: $scriptlang scriptfile:$scriptfile" + + #todo - allow sh scripts with no extension ... look at shebang etc? + if {$scriptfile ne "" && $scriptlang ne ""} { + set path [path_to_absolute $scriptfile $curdir $::tcl_platform(platform)] + if {[file type $path] eq "file"} { + set ext [file extension $path] + set extlower [string tolower $ext] + if {$extlower in $tcl_extensions} { + set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first + set ::argv0 $path + set ::argc [llength $newargs] + set ::argv $newargs + tailcall source $path + } elseif {$extlower in $py_extensions} { + set pycmd [auto_execok python] + tailcall {*}$pycmd {*}$args + } elseif {$extlower in $script_extensions} { + set exename [dict get $scriptconfig $scriptlang exe] + set cmd [auto_execok $exename] + tailcall {*}$cmd $args + } else { + set fd [open $path r] + set chunk [read $fd 4000]; close $fd + #consider any commented line near top of file containing 'tcl' as likely to be a tcl script of some sort and attempt to source it. + set toplines [split $chunk \n] + set tcl_indicator 0 + foreach ln $toplines { + set ln [string trim $ln] + if {[string match "#*tcl*" $ln]} { + set tcl_indicator 1 + break + } + } + if {$tcl_indicator} { + set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first. + set ::argv0 $path + set ::argc [llength $newargs] + set ::argv $newargs + tailcall source $path + } + puts stderr "Cannot run [file extension $path] file directly ([file tail $path]) as tcl script. Ensure file has a known tcl extension ($tcl_extensions) or add a commented hint in the file such as #!/usr/bin/env tclsh" + return [pwd] + } + } + } else { + puts stderr "No script executable known for this" + } + + } + + + proc dirlist {{location ""}} { + set contents [dirfiles_dict -with_times {f d l} -with_sizes {f d l} $location] + return [dirfiles_dict_as_lines -stripbase 1 $contents] + } + + + #dirfiles dirfiles_dict always deliberately return absolute *unnormalized* path + #e.g when cwd is c:/repo/jn/punk dirfiles ../../ will return something like: + # c:/repo/jn/punk/../../blah + #dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold + # dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream + punk::args::define { + @id -id ::punk::nav::fs::dirfiles + -stripbase -default 1 -type boolean + -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" + @values -min 0 -max -1 + } + proc dirfiles {args} { + set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args] + lassign [dict values $argd] leaders opts values_dict + + set opt_stripbase [dict get $opts -stripbase] + set opt_formatsizes [dict get $opts -formatsizes] + + #todo - support multiple searchspecs - dirfiles_dict should merge results when same folder + set searchspec "" + dict for {_index val} $values_dict { + set searchspec $val + break + } + + set relativepath [expr {[file pathtype $searchspec] eq "relative"}] + set has_tailglobs [regexp {[?*]} [file tail $searchspec]] + + #dirfiles_dict would handle simple cases of globs within paths anyway - but we need to explicitly set tailglob here in all branches so that next level doesn't need to do file vs dir checks to determine user intent. + #(dir-listing vs file-info when no glob-chars present is inherently ambiguous so we test file vs dir to make an assumption - more explicit control via -tailglob can be done manually with dirfiles_dict) + if {$relativepath} { + set searchbase [pwd] + if {!$has_tailglobs} { + if {[file isdirectory [file join $searchbase $searchspec]]} { + set location [file join $searchbase $searchspec] + set tailglob * + } else { + set location [file dirname [file join $searchbase $searchspec]] + set tailglob [file tail $searchspec] ;#use exact match as a glob - will retrieve size,attributes etc. + } + } else { + #tailglobs exist - and we operate under assumption globchars aren't present in file/folder names - so no folderness/fileness check needed. + set location [file dirname [file join $searchbase $searchspec]] + set tailglob [file tail $searchspec] + } + } else { + #for absolute paths - searchbase AND location will change depending on globiness of tail and fileness vs folderness + if {!$has_tailglobs} { + if {[file isdirectory $searchspec]} { + set searchbase $searchspec + set location $searchspec + set tailglob * + } else { + set searchbase [file dirname $searchspec] + set location [file dirname $searchspec] + set tailglob [file tail $searchspec] ;#literal glob for single file - retrieves properties + } + } else { + set searchbase [file dirname $searchspec] + set location [file dirname $searchspec] + set tailglob [file tail $searchspec] + } + } + puts "--> -searchbase:$searchbase searchspec:$searchspec -tailglob:$tailglob location:$location" + set contents [dirfiles_dict -searchbase $searchbase -tailglob $tailglob -with_times {f d l} -with_sizes {f d l} $location] + return [dirfiles_dict_as_lines -stripbase $opt_stripbase -formatsizes $opt_formatsizes $contents] + } + + #todo - package as punk::nav::fs + #todo - in thread + #todo - streaming version + #glob patterns in path prior to final segment should already be resolved before using dirfiles_dict - as the underlying filesystem mechanisms can't do nested globbing themselves. + #dirfiles_dict will assume the path up to the final segment is literal even if globchars are included therein. + #final segment globs will be recognised only if -tailglob is passed as empty string + #if -tailglob not supplied and last segment has globchars - presume searchspec parendir is the container and last segment is globbing within that. + #if -tailglob not supplied and last segment has no globchars - presume searchspec is a container(directory) and use glob * + #caller should use parentdir as location and set tailglob to search-pattern or exact match if location is intended to match a file rather than a directory + #examples: + # somewhere/files = search is effectively somewhere/files/* (location somewhere/files glob is *) + # somewhere/files/* = (as above) + # -tailglob * somewhere/files = (as above) + # + # -tailglob "" somewhere/files = search somewhere folder for exactly 'files' (location somewhere glob is files) + # -tailglob files somewhere = (as above) + # + # somewhere/f* = search somewhere folder for f* (location somewhere glob is f*) + # -tailglob f* somewhere = (as above) + # + # This somewhat clumsy API is so that simple searches can be made in a default sensible manner without requiring extra -tailglob argument for the common cases - with lack of trailing glob segment indicating a directory listing + # - but we need to distinguish somewhere/files as a search of that folder vs somewhere/files as a search for exactly 'files' within somewhere, hence the -tailglob option to fine-tune. + # - this also in theory allows file/directory names to contain glob chars - although this is probably unlikely and/or unwise and not likely to be usable on all platforms. + # + #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. + # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied + proc dirfiles_dict {args} { + set argspecs { + @id -id ::punk::nav::fs::dirfiles_dict + @opts -any 0 + -searchbase -default "" + -tailglob -default "\uFFFF" + #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) + -with_sizes -default "\uFFFF" -type string + -with_times -default "\uFFFF" -type string + @values -min 0 -max -1 -type string + } + set argd [punk::args::get_dict $argspecs $args] + lassign [dict values $argd] leaders opts vals + set searchspecs [dict values $vals] + + #puts stderr "searchspecs: $searchspecs [llength $searchspecs]" + #puts stdout "arglist: $opts" + + if {[llength $searchspecs] > 1} { + #review - spaced paths ? + error "dirfiles_dict: multiple listing not *yet* supported" + } + set searchspec [lindex $searchspecs 0] + # -- --- --- --- --- --- --- + set opt_searchbase [dict get $opts -searchbase] + set opt_tailglob [dict get $opts -tailglob] + set opt_with_sizes [dict get $opts -with_sizes] + set opt_with_times [dict get $opts -with_times] + # -- --- --- --- --- --- --- + + #we don't want to normalize.. + #for example if the user supplies ../ we want to see ../result + + set is_relativesearchspec [expr {[file pathtype $searchspec] eq "relative"}] + if {$opt_searchbase eq ""} { + set searchbase . + } else { + set searchbase $opt_searchbase + } + + + switch -- $opt_tailglob { + "" { + if {$searchspec eq ""} { + set location + } else { + if {$is_relativesarchspec} { + #set location [file dirname [file join $opt_searchbase $searchspec]] + set location [punk::path::normjoin $searchbase $searchspec ..] + } else { + set location [punk::path::normjoin $searchspec ..] + } + #here tail is treated as a search-pattern within location whether or not it contains glob chars "?" or "*" + set match_contents [file tail $searchspec] + } + } + "\uFFFF" { + set searchtail_has_globs [regexp {[*?]} [file tail $searchspec]] + if {$searchtail_has_globs} { + if {$is_relativesearchspec} { + #set location [file dirname [file join $searchbase $searchspec]] + #e.g subdir/* or sub/etc/x* + set location [punk::path::normjoin $searchbase $searchspec ..] + } else { + set location [punk::path::normjoin $searchspec ..] + } + set match_contents [file tail $searchspec] + } else { + #user didn't supply a glob within tail segment, nor did they specify a separate -tailglob - presume they want a directory listing + if {$searchspec eq ""} { + set location $searchbase + } else { + if {$is_relativesearchspec} { + #set location [file join $searchbase $searchspec] + set location [punk::path::normjoin $searchbase $searchspec] + } else { + #absolute path for search + set location $searchspec + } + } + set match_contents * + } + } + default { + #-tailglob supplied separately - ignore any globiness in tail segment of searchspec and treat literally + if {$searchspec eq ""} { + set location $searchbase + } else { + if {$is_relativesearchspec} { + #set location [file join $searchbase $searchspec] + set location [punk::path::normjoin $searchbase $searchspec] + } else { + set location $searchspec + } + } + set match_contents $opt_tailglob + } + } + #puts stdout "searchbase: $searchbase searchspec:$searchspec" + + + #file attr //cookit:/ returns {-vfs 1 -handle {}} + #we will treat it differently for now - use generic handler REVIEW + set in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit. + if {[llength [package provide vfs]]} { + foreach mount [vfs::filesystem info] { + if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} { + set in_vfs 1 + break + } + } + } + + if {$opt_with_sizes eq "\uFFFF"} { + #leave up to listing-provider defaults + set next_opt_with_sizes "" + } else { + set next_opt_with_sizes [list -with_sizes $opt_with_sizes] + } + if {$opt_with_times eq "\uFFFF"} { + #leave up to listing-provider defaults + set next_opt_with_times "" + } else { + set next_opt_with_times [list -with_times $opt_with_times] + } + if {$in_vfs} { + set listing [punk::du::lib::du_dirlisting_tclvfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + } else { + set in_zipfs 0 + set in_cookit 1 + set in_other_pseudovol 1 + switch -glob -- $location { + //zipfs:/* { + if {[info commands ::tcl::zipfs::mount] ne ""} { + set in_zipfs 1 + } + } + //cookit:/* { + set in_cookit 1 + } + default { + #handle 'other/unknown' that mounts at a volume-like path //pseudovol:/ + if {[regexp {//((?:(?!:|/).)+):/.*} $location _match pseudovol]} { + #pseudovol probably more than one char long + #we don't really expect something like //c:/ , but anyway, it's not the same as c:/ and for all we know someone could use that as a volume name? + set in_other_pseudovol 1 ;#flag so we don't use twapi - hope generic can handle it (uses tcl glob) + } else { + #we could use 'file attr' here to test if {-vfs 1} + #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) + #instead for now we'll assume any reasonable vfs should have been found by vfs::filesystem::info or mounted as a pseudovolume + } + + } + } + + if {$in_zipfs} { + #relative vs absolute? review - cwd valid for //zipfs:/ ?? + set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + } elseif {$in_cookit} { + #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ + #don't use twapi + #could possibly use du_dirlisting_tclvfs REVIEW + #files and folders are all returned with the -types hidden option for glob on windows + set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + } elseif {$in_other} { + set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + } else { + set listing [punk::du::dirlisting $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + } + } + + set dirs [dict get $listing dirs] + set files [dict get $listing files] + set filesizes [dict get $listing filesizes] + set vfsmounts [dict get $listing vfsmounts] + set flaggedhidden [dict get $listing flaggedhidden] + + + set nonportable [list] ;#illegal file/folder names for windows e.g trailing dot or trailing space - can still be read if //?/ AND shortname used + set underlayfiles [list] + set underlayfilesizes [list] + if {[llength $vfsmounts]} { + foreach vfsmount $vfsmounts { + if {[set fposn [lsearch $files $vfsmount]] >= 0} { + lappend underlayfiles [lindex $files $fposn] + set files [lreplace $files $fposn $fposn] + #for any change to files list must change filesizes too if list exists + if {[llength $filesizes]} { + lappend underlayfilesizes [lindex $filesizes $fposn] + set filesizes [lreplace $filesizes $fposn $fposn] + } + lappend dirs $vfsmount + } elseif {$vfsmount in $dirs} { + #either dirlisting mech was aware of vfs.. or mountpoint is overlaying an underlying folder + #for now - do nothing + #todo - review. way to query dirlisting mech to see if we are hiding a folder? + + } else { + #vfs mount but dirlisting mechanism didn't detect as file or folder + lappend dirs $vfsmount + } + } + } + + + #NOTE: -types {hidden d} * may return . & .. on unix platforms - but will not show them on windows. + #A mounted vfs exe (e.g sometclkit.exe) may be returned by -types {hidden d} on windows - but at the same time has "-hidden 0" in the result of file attr. + + #non-unix platforms may have attributes to indicate hidden status even if filename doesn't have leading dot. + #mac & windows have these + #windows doesn't consider dotfiles as hidden - mac does (?) + #we add dotfiles to flaggedhidden list in case there is some other mechanism that has flagged items as hidden + if {$::tcl_platform(platform) ne "windows"} { + lappend flaggedhidden {*}[lsearch -all -inline [list {*}$dirs {*}$files] ".*"] + #e.g we can have dupes in the case where there are vfs mounted files that appear as dirs + #as we will need to do a (nat)sort as a last step - it will be faster to not sort items prematurely + #set flaggedhidden [lsort -unique $flaggedhidden] + set flaggedhidden [punk::lib::lunique_unordered $flaggedhidden] + } + + set dirs [lsort $dirs] ;#todo - natsort + + + + #foreach d $dirs { + # if {[lindex [file system $d] 0] eq "tclvfs"} { + # lappend vfs $d [file system $d] + # } + #} + + #glob -types {hidden} will not always return the combination of glob -types {hidden f} && -types {hidden d} (on windows anyway) + + # -- --- + #can't lsort files without lsorting filesizes + #Note - the sort by index would convert an empty filesizes list to a list of empty strings - one for each entry in files + #We want to preserve the empty list if that's what the dirlisting mechanism returned (presumably because -with_sizes was 0 or explicitly excluded files) + if {[llength $filesizes] == 0} { + set sorted_files [lsort $files] + set sorted_filesizes [list] + } else { + set sortorder [lsort -indices $files] + set sorted_files [list] + set sorted_filesizes [list] + foreach i $sortorder { + lappend sorted_files [lindex $files $i] + lappend sorted_filesizes [lindex $filesizes $i] + } + } + + set files $sorted_files + set filesizes $sorted_filesizes + # -- --- + + + #jmn + foreach nm [list {*}$dirs {*}$files] { + if {[punk::winpath::illegalname_test $nm]} { + lappend nonportable $nm + } + } + set front_of_dict [dict create location $location searchbase $opt_searchbase] + set listing [dict merge $front_of_dict $listing] + + set updated [dict create dirs $dirs files $files filesizes $filesizes nonportable $nonportable flaggedhidden $flaggedhidden underlayfiles $underlayfiles underlayfilesizes $underlayfilesizes] + return [dict merge $listing $updated] + } + + punk::args::define { + @id -id ::punk::nav::fs::dirfiles_dict_as_lines + -stripbase -default 0 -type boolean + -formatsizes -default 1 -type boolean + @values -min 1 -max -1 -type dict + } + + #todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing? + proc dirfiles_dict_as_lines {args} { + package require overtype + set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles_dict_as_lines $args] + lassign [dict values $argd] leaders opts vals + set list_of_dicts [dict values $vals] + + + + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_stripbase [dict get $opts -stripbase] + set opt_formatsizes [dict get $opts -formatsizes] + # -- --- --- --- --- --- --- --- --- --- --- --- + + #if multiple dicts and -stripbase = 1 - we can only strip the longest common part of the searchbases supplied + set common_base "" + set searchbases [list] + set searchbases_with_len [list] + if {$opt_stripbase} { + #todo - case-insensitive comparisons on platforms where that is appropriate (e.g windows) + # - note that the OS could be configured differently in this regard than the default (as could a filesystem such as ZFS), and that for example mounted SMB filesystems are likely to be configured to support the general windows client idea of case-preserving-but-case-insensitive. + # - we may be able to provide a reasonable default for windows vs other - but a proc option is likely needed to allow caller to override the default behaviour on a call by call basis, + # and a config option may be desirable for the user to override the platform default. + # The chosen defaults based on platform may be generally ok - but then not give the desired behaviour when accessing a particular filesystem/mount + if {$::tcl_platform(platform) eq "windows"} { + #case-preserving but case-insensitive matching is the default + foreach d $list_of_dicts { + set str [string tolower [string trim [dict get $d searchbase]]] + lappend searchbases $str + lappend searchbases_with_len [list $str [string length $str]] + } + } else { + #case sensitive + foreach d $list_of_dicts { + set str [string trim [dict get $d searchbase]] + lappend searchbases $str + lappend searchbases_with_len [list $str [string length $str]] + } + } + #if any of the searchbases is empty - there will be no common base - so leave common_base as empty string. + if {"" ni $searchbases} { + set shortest_to_longest [lsort -index 1 -integer $searchbases_with_len] + set prefix_test_list [tcl::prefix all $searchbases [lindex $shortest_to_longest 0 0]] + #if shortest doesn't match all searchbases - we have no common base + if {[llength $prefix_test_list] == [llength $searchbases]} { + set common_base [lindex $shortest_to_longest 0 0]; #we + } + } + } + + foreach fileset [list dirs files links underlayfiles flaggedhidden flaggedreadonly flaggedsystem nonportable vfsmounts] { + set $fileset [list] + } + + #set contents [lindex $list_of_dicts 0] + foreach contents $list_of_dicts { + lappend dirs {*}[dict get $contents dirs] + lappend files {*}[dict get $contents files] + lappend links {*}[dict get $contents links] + lappend filesizes {*}[dict get $contents filesizes] + lappend underlayfiles {*}[dict get $contents underlayfiles] + lappend underlayfilesizes {*}[dict get $contents underlayfilesizes] + lappend flaggedhidden {*}[dict get $contents flaggedhidden] + lappend flaggedreadonly {*}[dict get $contents flaggedreadonly] + lappend flaggedsystem {*}[dict get $contents flaggedsystem] + lappend nonportable {*}[dict get $contents nonportable] ;# illegal file/folder names from windows perspective + lappend vfsmounts {*}[dict get $contents vfsmounts] + } + + set fkeys [dict create] ;#avoid some file normalize calls.. + if {$opt_stripbase && $common_base ne ""} { + set filetails [list] + set dirtails [list] + foreach fileset [list dirs files links underlayfiles flaggedhidden flaggedreadonly flaggedsystem nonportable vfsmounts] { + set stripped [list] + foreach fullname [set $fileset] { + set shortname [strip_prefix_depth $fullname $common_base] + dict set fkeys $shortname $fullname ;#cache so we can retrieve already normalised name without re-hitting filesystem + lappend stripped $shortname + } + set $fileset $stripped + } + #Note: without fkeys we would need to remember to use common_base to rebuild (and file normalize!) the key when we need to query the dict-based elements: sizes & times - because we didn't strip those keys. + } + + # -- --- --- --- --- --- --- --- --- --- --- + #assign symlinks to the dirs or files collection (the punk::du system doesn't sort this out + #As at 2024-09 for windows symlinks - Tcl can't do file readlink on symlinks created with mklink /D name target (SYMLINKD) or mklink name target (SYMLINK) + #We can't read the target information - best we can do is classify it as a file or a dir + #we can't use 'file type' as that will report just 'link' - but file isfile and file isdirectory work and should work for links on all platforms - REVIEW + set file_symlinks [list] + set dir_symlinks [list] + set dir_shortcuts [list] ;#windows shell links (.lnk) that have a target that is a directory + foreach s $links { + if {[dict exists $contents linkinfo $s target_type]} { + #some mechanisms such as twapi can provide the target_type info so we don't have to re-hit the filesystem. + set target_type [dict get $contents linkinfo $s target_type] + switch -- $target_type { + file { + lappend file_symlinks $s + } + directory { + lappend dir_symlinks $s + lappend dirs $s + } + default { + puts stderr "Warning - cannot determine link type for link $s (target_type value is:$target_type)" + } + } + } else { + #fallback if no target_type + if {[file isfile $s]} { + lappend file_symlinks $s + #will be appended in finfo_plus later + } elseif {[file isdirectory $s]} { + lappend dir_symlinks $s + lappend dirs $s + } else { + #dunno - warn for now + puts stderr "Warning - cannot determine link type for link $s" + } + } + } + #we now have the issue that our symlinks aren't sorted within the dir/file categorisation - they currently will have to appear at beginning or end - TODO + # -- --- --- --- --- --- --- --- --- --- --- + + + #todo - sort whilst maintaining order for metadata? + #we need to co-sort files only with filesizes (other info such as times is keyed on fname so cosorting not required) + + + #we can't sort on filesize after format_number (unless we were to enforce delim _ which we don't want to do) + if {$opt_formatsizes} { + set filesizes [punk::lib::format_number $filesizes] ;#accepts a list and will process each + } + + #col2 (file info) with subcolumns + + set widest2a [tcl::mathfunc::max {*}[lmap v [list {*}$files {*}$file_symlinks ""] {string length $v}]] + + set c2a [string repeat " " [expr {$widest2a + 1}]] + #set widest2b [punk::pipedata [list {*}$filesizes ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + set widest2b [tcl::mathfunc::max {*}[lmap v [list {*}$filesizes ""] {string length $v}]] + set c2b [string repeat " " [expr {$widest2b + 1}]] + + #c2c timestamp and short note - fixed width 19 for ts + + filetype note e.g "symlink" "shortcut" "binary" ?? combinations? allow 2 words 10 each for 21 + 1 for luck + # total 42 + set c2c [string repeat " " 42] + set finfo [list] + foreach f $files s $filesizes { + if {[dict size $fkeys]} { + set key [dict get $fkeys $f] + } else { + #not stripped - they should match + set key $f + } + #note - the display entry isn't necessarily a valid tcl list e.g filename with unbalanced curly braces + #hence we need to keep the filename as well, properly protected as a list element + if {[dict exists $contents times $key m]} { + set mtime [dict get $contents times $key m] + set ts [tcl::clock::format $mtime -format "%Y-%m-%d %H:%M:%S"] + } else { + #set ts [string repeat { } 19] + set ts "$key vs [dict keys [dict get $contents times]]" + } + set note "" + lappend finfo [list file $f display "[overtype::left $c2a $f] [overtype::right $c2b $s] [overtype::left $c2c "$ts $note"]"] + } + set flink_style [punk::ansi::a+ undercurly underline undt-green] ;#curly green underline with fallback to normal underline + set dlink_style [punk::ansi::a+ undercurly underline undt-green] + #We use an underline so the visual styling of a link can coexist with fg/bg colors applied for other attributes such as hidden + foreach flink $file_symlinks { + if {[dict size $fkeys]} { + set key [dict get $fkeys $flink] + } else { + set key $flink + } + if {[dict exists $contents times $key m]} { + set mtime [dict get $contents times $key m] + set ts [tcl::clock::format $mtime -format "%Y-%m-%d %H:%M:%S"] + } else { + set ts "[string repeat { } 19]" + } + set note "link" ;#default only + if {[dict exists $contents linkinfo $key linktype]} { + if {[dict get $contents linkinfo $key linktype] eq "reparse_point"} { + set note "reparse_point" + if {[dict exists $contents linkinfo $key reparseinfo tag]} { + append note " " [dict get $contents linkinfo $key reparseinfo tag] + } + } else { + append note "$key vs [dict keys [dict get $contents linkinfo]]" + } + } + lappend finfo [list file $flink display "$flink_style[overtype::left $c2a $flink] [overtype::right $c2b 0] [overtype::left $c2c "$ts $note"]"] + } + + set fshortcut_style [punk::ansi::a+ underdotted underline undt-hotpink] + set dshortcut_style [punk::ansi::a+ underdotted underline undt-hotpink] + #examine windows .lnk shell link files (shortcuts) - these could be encountered on other platforms too - we should still be able to read them + #review - symlink to shortcut? hopefully will just work + #classify as file or directory - fallback to file if unknown/undeterminable + set finfo_plus [list] + foreach fdict $finfo { + set fname [dict get $fdict file] + if {[file extension $fname] eq ".lnk"} { + if {![catch {package require punk::winlnk}]} { + set shortcutinfo [punk::winlnk::file_get_info $fname] + set target_type "file" ;#default/fallback + if {[dict exists $shortcutinfo link_target]} { + set is_valid_lnk 1 + set tgt [dict get $shortcutinfo link_target] + if {[file exists $tgt]} { + #file type could return 'link' - we will use isfile/isdirectory + if {[file isfile $tgt]} { + set target_type file + } elseif {[file isdirectory $tgt]} { + set target_type directory + } else { + set target_type file ;## ? + } + } else { + #todo - see if punk::winlnk has info about the type at the time of linking + #for now - treat as file + } + } else { + #no link_target - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. + set is_valid_lnk 0 + } + if {$is_valid_lnk} { + switch -- $target_type { + file { + set display [dict get $fdict display] + set display "$fshortcut_style$display (shortcut $tgt)" ;# + dict set fdict display $display + lappend finfo_plus $fdict + } + directory { + #target of link is a dir - for display/categorisation purposes we want to see it as a dir + #will be styled later based on membership of dir_shortcuts + lappend dirs $fname + lappend dir_shortcuts $fname + } + } + } else { + #we were unable to get link_target - but we still need to check if it failed the header check (then assume not intended to be a windows shell lnk) or for some other reason. + if {[dict exists $shortcutinfo error]} { + if {[dict get $shortcutinfo error] ne "lnk_header_check_failed"} { + #Presumably there is a valid lnk header, but some unexpected error occurred - show it in the display for the file + #still style as a windows shell lnk - as to get here, the header check must have passed. + set display [dict get $fdict display] + set display "$fshortcut_style$display (shortcut error [dict get $shortcutinfo error])" ;# + dict set fdict display $display + lappend finfo_plus $fdict + } else { + #error of lnk_header_check_failed means it probably just isn't a windows shell link. Leave ordinary display for file. + lappend finfo_plus $fdict + } + } else { + #shouldn't ever happen. If no error, then there should have been a link_target + #report and move on + puts stderr "Unexpected error in result of parsing binary format for $fname" + lappend finfo_plus $fdict + } + } + #assert - we have either appended to finfo_plus (possibly with shortcut info/error if binary header was valid) - or appended to dirs (if it was a valid lnk and target was a dir) + } + #if we don't have punk::winlnk to read the .lnk - it will get no special highlighting and just appear as an ordinary file even if it points to a dir + } else { + lappend finfo_plus $fdict + } + } + unset finfo + + + + #set widest1 [punk::pipedata [list {*}$dirs ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + #set widest1 [tcl::mathfunc::max {*}[lmap v [concat $dirs [list ""]] {string length $v}]] + set widest1 [tcl::mathfunc::max {*}[lmap v [list {*}$dirs ""] {string length $v}]] + + set displaylist [list] + set col1 [string repeat " " [expr {$widest1 + 2}]] + set RST [punk::ansi::a] + foreach d $dirs filerec $finfo_plus { + set d1 [punk::ansi::a+ cyan bold] + set d2 [punk::ansi::a+ defaultfg defaultbg normal] + #set f1 [punk::ansi::a+ white bold] + set f1 [punk::ansi::a+ white] + set f2 [punk::ansi::a+ defaultfg defaultbg normal] + set fdisp "" + if {[string length $d]} { + if {$d in $flaggedhidden} { + set d1 [punk::ansi::a+ cyan normal] + } + if {$d in $vfsmounts} { + if {$d in $flaggedhidden} { + #we could have a hidden dir which is also a vfs.. colour will be overridden giving no indicatio of 'hidden' status - REVIEW + #(This situation encountered on windows - even though file attr showed -hidden 0 - the glob with -types hidden returned it.. possibly a tcl glob bug on windows) + #mark it differently for now.. (todo bug report?) + if {$d in $nonportable} { + set d1 [punk::ansi::a+ red Yellow bold] + } else { + set d1 [punk::ansi::a+ green Purple bold] + } + } else { + if {$d in $nonportable} { + set d1 [punk::ansi::a+ red White bold] + } else { + set d1 [punk::ansi::a+ green bold] + } + } + } else { + if {$d in $nonportable} { + set d1 [punk::ansi::a+ red bold] + } + } + #dlink-style & dshortcut_style are for underlines - can be added with colours already set + if {$d in $dir_symlinks} { + append d1 $dlink_style + } elseif {$d in $dir_shortcuts} { + append d1 $dshortcut_style + } + } + if {[llength $filerec]} { + set fname [dict get $filerec file] + set fdisp [dict get $filerec display] + if {$fname in $flaggedhidden} { + set f1 [punk::ansi::a+ Purple] + } else { + if {$fname in $nonportable} { + set f1 [punk::ansi::a+ red bold] + } + } + } + lappend displaylist [overtype::left $col1 $d1$d$RST]$f1$fdisp$RST + } + + return [punk::lib::list_as_lines $displaylist] + } + + #pass in base and platform to head towards purity/testability. + #this function can probably never be pure in such a simple form - as it needs to read state from the os storage system configuration + #consider haskells approach of well-typed paths for cross-platform paths: https://hackage.haskell.org/package/path + #review: punk::winpath calls cygpath! + #review: file pathtype is platform dependant + proc path_to_absolute {path base platform} { + set ptype [file pathtype $path] + if {$ptype eq "absolute"} { + set path_absolute $path + } elseif {$ptype eq "volumerelative"} { + if {$platform eq "windows"} { + #unix looking paths like /c/users or /usr/local/etc are reported by tcl as volumerelative.. (as opposed to absolute on unix platforms) + if {[string index $path 0] eq "/"} { + #this conversion should be an option for the ./ command - not built in as a default way of handling volumerelative paths here + #It is more useful on windows to treat /usr/local as a wsl or mingw path - and may be reasonable for ./ - but is likely to surprise if put into utility functions. + #Todo - tidy up. + package require punk::unixywindows + set path_absolute [punk::unixywindows::towinpath $path] + #puts stderr "winpath: $path" + } else { + #todo handle volume-relative paths with volume specified c:etc c: + #note - tcl doesn't handle this properly anyway.. the win32 api should 'remember' the per-volume cwd + #not clear whether tcl can/will fix this - but it means these paths are dangerous. + #The cwd of the process can get out of sync with what tcl thinks is the working directory when you swap drives + #Arguably if ...? + + #set path_absolute $base/$path + set path_absolute $path + } + } else { + # unknown what paths are reported as this on other platforms.. treat as absolute for now + set path_absolute $path + } + } else { + set path_absolute $base/$path + } + if {$platform eq "windows"} { + if {[punk::winpath::illegalname_test $path_absolute]} { + set path_absolute [punk::winpath::illegalname_fix $path_absolute] ;#add dos-device-prefix protection if not already present + } + } + return $path_absolute + } + proc strip_prefix_depth {path prefix} { + set tail [lrange [file split $path] [llength [file split $prefix]] end] + if {[llength $tail]} { + return [file join {*}$tail] + } else { + return "" + } + } + + #REVIEW - at least one version of Tcl during development couldn't navigate using cd to intermediate paths between the zipfs root and the mountpoint. + #TODO - test if this can still occur. + proc Zipfs_path_within_zipfs_mounts {zipfspath} { + if {![string match //zipfs:/* $zipfspath]} {error "Zipfs_path_within_zipfs_mounts error. Supplied zipfspath $zipfspath must be a //zipfs:/* path"} + set is_within_mount 0 + dict for {zmount zpath} [zipfs mount] { + if {[punk::mix::base::lib::path_a_atorbelow_b $zipfspath $zmount]} { + set is_within_mount 1 + break + } + } + return $is_within_mount + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::nav::fs ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::nav::fs::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::nav::fs::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::nav::fs::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::nav::fs::system { + #*** !doctools + #[subsection {Namespace punk::nav::fs::system}] + #[para] Internal functions that are not part of the API + + #ordinary emission of chunklist when no repl + proc emit_chunklist {chunklist} { + set result "" + foreach record $chunklist { + lassign $record type data + switch -- $type { + stdout { + puts stdout "$data" + } + stderr { + puts stderr $data + } + result {} + default { + puts stdout "$type $data" + } + } + } + return $result + } + + proc codethread_is_running {} { + if {[info commands ::punk::repl::codethread::is_running] ne ""} { + return [punk::repl::codethread::is_running] + } + return 0 + } + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::nav::fs [tcl::namespace::eval punk::nav::fs { + variable pkg punk::nav::fs + 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/ns-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index 70f924d7..4eb6526d 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -20,15 +20,28 @@ package require punk::lib package require punk::args -tcl::namespace::eval ::punk_dynamic::ns { - +tcl::namespace::eval ::punk::ns::evaluator { + #eval-_NS_xxx_NS_etc procs } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::ns { - variable ns_current "::" + variable ns_current + #allow presetting + if {![info exists ::punk::ns::ns_current]} { + set ns_current :: + } + variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns - namespace export nsjoin nsprefix nstail nsparts nseval nsimport_noclobber corp + namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp + namespace path {::punk::lib ::punk::ansi} ;#list_as_lines etc + + catch { + package require debug + debug define punk.ns.compile + #debug on punk.ns.compile + #debug level punk.ns.compile 3 + } #leading colon makes it hard (impossible?) to call directly if not within the namespace proc ns/ {v {ns_or_glob ""} args} { @@ -47,6 +60,8 @@ tcl::namespace::eval punk::ns { set nspathcommands 1 } + set ns_or_glob [string map {:::: ::} $ns_or_glob] + #todo - cooperate with repl? set out "" if {$ns_or_glob eq ""} { @@ -58,7 +73,7 @@ tcl::namespace::eval punk::ns { set has_globchars [regexp {[*?]} $ns_or_glob] if {$is_absolute} { if {!$has_globchars} { - if {![tcl::namespace::exists $ns_or_glob]} { + if {![nsexists $ns_or_glob]} { error "cannot change to namespace $ns_or_glob" } set ns_current $ns_or_glob @@ -71,7 +86,7 @@ tcl::namespace::eval punk::ns { } else { if {!$has_globchars} { set nsnext [nsjoin $ns_current $ns_or_glob] - if {![tcl::namespace::exists $nsnext]} { + if {![nsexists $nsnext]} { error "cannot change to namespace $ns_or_glob" } set ns_current $nsnext @@ -151,14 +166,28 @@ tcl::namespace::eval punk::ns { } #todo - walk up each ns - testing for possibly weirdly named namespaces - #review - do we even need it. + #needed to use n/ to change to an oddly named namespace such as ":x" proc nsexists {nspath} { - error "unimplemented" + if {$nspath eq ""} {return 0} + set parts [nsparts $nspath] + if {[lindex $parts 0] ne ""} { + #relative + set ns_caller [uplevel 1 {::namespace current}] + set fq_nspath [nsjoin $ns_caller $nspath] + } else { + set fq_nspath $nspath + } + if {[catch {nseval_ifexists $fq_nspath {}}]} { + return 0 + } else { + return 1 + } } #recursive nseval - for introspection of weird namespace trees #approx 10x slower than normal tcl::namespace::eval - but still only a few microseconds.. fine for repl introspection - proc nseval_script {location} { + #WARNING: creates namespaces if they don't exist + proc nseval_getscript {location} { set parts [nsparts $location] if {[lindex $parts 0] eq ""} { lset parts 0 :: @@ -200,28 +229,96 @@ tcl::namespace::eval punk::ns { return $body } proc nseval {fqns script} { + #create one proc for each fully qualified namespace to evaluate script if {![string match ::* $fqns]} { error "nseval only accepts a fully qualified namespace" } - set loc [string map {:: _sep_} $fqns] + set loc [string map {:: _NS_} $fqns] #set cmd ::punk::pipecmds::nseval_$loc - set cmd ::punk_dynamic::ns::eval-$loc + set cmd ::punk::ns::evaluator::eval-$loc if {$cmd ni [info commands $cmd]} { - append body \n [nseval_script $fqns] + append body \n [nseval_getscript $fqns] proc $cmd {script} $body - debug.punk.pipe.compile {proc $cmd} 6 + debug.punk.ns.compile {proc $cmd} 2 } tailcall $cmd $script } - proc nschildren {fqns} { - if {![string match ::* $fqns]} { - error "nschildren only accepts a fully qualified namespace" + proc nseval_ifexists {ns script} { + set parts [nsparts $ns] + if {[lindex $parts 0] ne ""} { + #relative + set nscaller [uplevel 1 {::tcl::namespace::current}] + set nsfq [nsjoin $nscaller $ns] + } else { + set nsfq $ns } + set ns_script [nseval_ifexists_getscript $nsfq] + uplevel 1 [list {*}$ns_script $script] + } + proc nseval_ifexists_getscript {location} { + set parts [nsparts $location] + if {[lindex $parts 0] eq ""} { + lset parts 0 :: + } + if {[lindex $parts end] eq ""} { + set parts [lrange $parts 0 end-1] + } + + set body "apply \{{script} \{eval \[string map \[list \$script\] \{" + set i 0 + set tails [lrepeat [llength $parts] ""] + foreach ns $parts { + set cmdlist [list ::punk::ns::eval_no_create $ns] + set t "" + if {$i > 0} { + append body " " + } + append body $cmdlist + if {$i == ([llength $parts] -1)} { + append body " {}" + } + if {$i > 0} { + set t {} + } + lset tails $i $t + incr i + } + append body [join [lreverse $tails] " "] + #puts stdout "tails: $tails" + #puts stdout "i: $i" + set body [string map [list "\{" "\}"] $body] + append body " \}\]\}\}" + return $body + } + proc eval_no_create {ns script} { + uplevel 1 [string map [list $ns $script] { + if {[::tcl::namespace::exists ]} { + ::tcl::namespace::eval {} + } else { + error "no such namespace " + } + }] + } + + + proc nschildren {ns} { + set parts [nsparts $ns] + if {[lindex $parts 0] ne ""} { + #relative + set nscaller [uplevel 1 {::tcl::namespace::current}] + set fqns [nsjoin $nscaller $ns] + } else { + set fqns $ns + } + #if {![string match ::* $fqns]} { + # error "nschildren only accepts a fully qualified namespace" + #} set parent [nsprefix $fqns] set tail [nstail $fqns] #puts ">>> parent $parent tail $tail" #set nslist [nseval $parent [list ::namespace children $tail]] - set nslist [tcl::namespace::eval $parent [list ::tcl::namespace::children $tail]] + #set nslist [tcl::namespace::eval $parent [list ::tcl::namespace::children $tail]] + set nslist [nseval_ifexists $parent [list ::tcl::namespace::children $tail]] return [lsort $nslist] } @@ -349,7 +446,16 @@ tcl::namespace::eval punk::ns { set searchns [nsprefix $ns_absolute] ;#the ns within which we want to searchns set searchall [nsjoin $searchns *] ;#will correctly form ::* or ::childns::* - set rawresult [info vars $searchall] ;#will not find vars in ::x:::y etc. - seems to be impossible in tcl 8.x + set nsparts [nsparts $searchns] + set weird_ns 0 + if {[lsearch $nsparts :*] >=0} { + set weird_ns 1 + } + if {$weird_ns} { + set rawresult [nseval_ifexists $searchns [list info vars]] + } else { + set rawresult [info vars $searchall] ;#will not find vars in ::x:::y etc. - seems to be impossible in tcl 8.x + } set matched_fullpath [list] foreach r $rawresult { lappend matched_fullpath [nstail $r] @@ -588,10 +694,21 @@ tcl::namespace::eval punk::ns { return $nslist } + variable usageinfo_char \U1f6c8 + # command has usageinfo e.g from punk::args. todo cmdline, argp, tepam etc? + proc Usageinfo_mark {{ansicodes \UFFEF}} { + variable usageinfo_char + if {$ansicodes eq ""} { + return $usageinfo_char + } elseif {$ansicodes eq "\UFFEF"} { + return " [a+ brightyellow]$usageinfo_char[a]" + } else { + return " [a+ {*}$ansicodes]$usageinfo_char[a]" + } + } #REVIEW - ansi codes can be *very* confusing to the user when trying to handle lists etc.. proc get_nslist {args} { - set known_types [list children commands exported imported aliases procs ensembles ooclasses ooobjects ooprivateobjects ooprivateclasses native coroutines interps zlibstreams] set defaults [dict create\ -match ""\ @@ -659,6 +776,7 @@ tcl::namespace::eval punk::ns { set interps [list] set coroutines [list] set zlibstreams [list] + set usageinfo [list] if {$opt_nsdict eq ""} { set nsmatches [get_ns_dicts $fq_glob -allbelow 0] @@ -735,6 +853,7 @@ tcl::namespace::eval punk::ns { } } } + set usageinfo [dict get $contents usageinfo] } set numchildren [llength $children] @@ -755,7 +874,9 @@ tcl::namespace::eval punk::ns { set seencmds [list] set masked [list] ;# - set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] + #jmn + #set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] + set cmdsets [list {*}$procs {*}$ensembles {*}$ooclasses {*}$ooobjects {*}$ooprivateobjects {*}$ooprivateclasses {*}$native {*}$interps {*}$coroutines {*}$zlibstreams] foreach a $aliases { if {[list c $a] in $elements} { #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo @@ -798,14 +919,23 @@ tcl::namespace::eval punk::ns { - set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] - set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + #set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + set lenlist1 [lmap v [list {*}$children1 ""] {string length $v}] + set chwidest1 [tcl::mathfunc::max {*}$lenlist1] + + #set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + set chwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$children2 ""] {string length $v}]] #wrap the cmd in [list] (just for the width calc) to get a proper length for what will actually be displayed - set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] - set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] - set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] - set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] + #set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] + set cmdwidest1 [tcl::mathfunc::max {*}[lmap v [list {*}$elements1 ""] {string length [list [lindex $v 1]]}]] + + #set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] + set cmdwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$elements2 ""] {string length [list [lindex $v 1]]}]] + #set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] + set cmdwidest3 [tcl::mathfunc::max {*}[lmap v [list {*}$elements3 ""] {string length [list [lindex $v 1]]}]] + #set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] + set cmdwidest4 [tcl::mathfunc::max {*}[lmap v [list {*}$elements4 ""] {string length [list [lindex $v 1]]}]] set displaylist [list] set col1 [string repeat " " [expr {$chwidest1 + 8}]] @@ -841,7 +971,8 @@ tcl::namespace::eval punk::ns { set cmd_display [list $cmd] ;#wrap in list so empty command is visible (and distinguishable from for example a double-curly command) if {$cmd ni $commands && $cmd in $aliases } { #ordinary un-masked commandless-alias - set c [a+ red bold] + #(original alias name that has been renamed) + set c [a+ red bold strike] set prefix "${a}als " set prefix [overtype::right $prefix "-R"] } else { @@ -851,7 +982,7 @@ tcl::namespace::eval punk::ns { #keep oooobjects below ooclasses, ooprivateclasses, ooprivateobjects if {$cmd in $aliases && $cmd in $seencmds} { #masked commandless-alias - #assertion member of masked - but we use seencmds instead to detect. + #assertion: member of masked - but we use seencmds instead to detect. set c [a+ yellow bold] set prefix "${a}als " set prefix [overtype::right $prefix "-R"] @@ -883,13 +1014,20 @@ tcl::namespace::eval punk::ns { set prefix [overtype::right $prefix "-[a+ yellow bold]I[a+]"] } } - set cmd$i "${prefix} $c$cmd_display" - set c$i $c + if {$cmd in $usageinfo} { + set u [Usageinfo_mark brightgreen] + } else { + set u "" + } + set cmd$i "${prefix} $c$cmd_display$u" + #set c$i $c + set c$i "" lappend seencmds $cmd } } - lappend displaylist $a1[overtype::left $col1 $ch1][a+]$a1[overtype::left $col2 $ch2][a+]$c1[overtype::left $col3 $cmd1][a+]$c2[overtype::left $col4 $cmd2][a+]$c3[overtype::left $col5 $cmd3][a+]$c4$cmd4[a+] + #lappend displaylist $a1[overtype::left $col1 $ch1][a+]$a1[overtype::left $col2 $ch2][a+]$c1[overtype::left $col3 $cmd1][a+]$c2[overtype::left $col4 $cmd2][a+]$c3[overtype::left $col5 $cmd3][a+]$c4$cmd4[a+] + lappend displaylist $a1[overtype::left $col1 $ch1][a]$a1[overtype::left $col2 $ch2][a]$c1[overtype::left $col3 $cmd1][a]$c2[overtype::left $col4 $cmd2][a]$c3[overtype::left $col5 $cmd3][a]$c4$cmd4[a] } return [list_as_lines $displaylist] @@ -899,7 +1037,7 @@ tcl::namespace::eval punk::ns { if {$path_is_absolute} { return $nspath } - set ns_caller [uplevel 1 {::namespace current}] ;#must qualify. Needs to be called from arbitrary namespaces where 'namespace' command may exist (e.g tdom::schema) + set ns_caller [uplevel 1 {::namespace current}] ;#must qualify 'namespace' command. Needs to be called from arbitrary namespaces where 'namespace' command may exist (e.g tdom::schema) if {$nspath eq "\uFFFF"} { return $ns_caller } @@ -918,6 +1056,31 @@ tcl::namespace::eval punk::ns { return [nsjoin $base $nspath] } + set has_textblock [expr {![catch {package require textblock}]}] + + if {$has_textblock} { + interp alias "" ::punk::ns::Block_width "" textblock::width + } else { + #maint - equiv of textblock::width + proc Block_width {textblock} { + if {$textblock eq ""} { return 0 } + if {[tcl::string::last \t $textblock] >=0} { + if {[tcl::info::exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set textblock [textutil::tabify::untabify2 $textblock $tw] + } + if {[punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::ansistripraw $textblock] + } + if {[tcl::string::last \n $textblock] >= 0} { + return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + } + return [punk::char::ansifreestring_width $textblock] + } + } proc nslist {{glob "*"} args} { set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] if {[dict exists $args -match]} { @@ -929,7 +1092,6 @@ tcl::namespace::eval punk::ns { -nspathcommands 0\ ] - package require textblock set opts [dict merge $defaults $args] # -- --- --- set opt_nspathcommands [dict get $opts -nspathcommands] @@ -953,11 +1115,11 @@ tcl::namespace::eval punk::ns { set block [get_nslist {*}$opts] #if {[string first \n $block] < 0} { # #single line - # set width [textblock::width [list $block]] + # set width [Block_width [list $block]] #} else { - # set width [textblock::width $block] + # set width [Block_width $block] #} - set width [textblock::width $block] + set width [Block_width $block] #if multiple results or if there is only 1 result - but we are path-globbing - then we need to show location if {$count_with_results > 1 || [regexp {[*?]} [nsprefix $ns_absolute]]} { @@ -980,7 +1142,7 @@ tcl::namespace::eval punk::ns { } } append output $path_text - set path_text_width [textblock::width $path_text] + set path_text_width [Block_width $path_text] append output \n [string repeat - [expr {max($width,$path_text_width)}]] } elseif {$count_with_results > 1 && $width > 0 } { append output \n [string repeat - $width] @@ -996,9 +1158,44 @@ tcl::namespace::eval punk::ns { #info cmdtype available in 8.7+ #safe interps also seem to have it disabled for some reason + #we need to return "na" if 'info cmdtype' not supported or not functioning due to safe interp etc + #IMPORTANT: don't detect easy types such as proc/import here - caller needs the 'na' to do the proper fallback + #it is not desirable to do a partial cmdtype support here proc cmdtype {cmd} { + #set cmd [namespace which $cmd] ;#will return empty result for empty string command or command such as :x or any command that doesn't exist + set fqcmd [namespace which $cmd] ;#will resolve for example 'namespace path' reachable commands + if {$fqcmd eq ""} { + #e.g ::ns:::x will return empty result from namespace which even if :x is a command in ::ns + set where [nsprefix $cmd] + if {$where eq ""} { + #bare command that didn't resolve using namespace which + #command probably doesn't exist (may be auto_path cmd not yet loaded) + set where :: + } + set what [nstail $cmd] + } else { + set where [nsprefix $fqcmd] + set what [nstail $fqcmd] + } + #ensure we con't call 'namespace eval' on a nonexistent ns and create cruft namespaces + set parts [nsparts $where] + if {[lsearch $parts :*] > -1} { + set weird_ns 1 + if {![nsexists $where]} { + #error "punk::ns::cmdtype could not locate command $cmd (namespace '$where' not found)." + return nsnotfound + } + } else { + set weird_ns 0 + if {![namespace exists $where]} { + #error "punk::ns::cmdtype could not locate command $cmd (namespace '$where' not found)" + return nsnotfound + } + } + if {[interp issafe]} { - if {[catch {::tcl::info::cmdtype $cmd} result]} { + #todo - weird_ns + if {[catch {namespace eval $where [list ::tcl::info::cmdtype $what]} result]} { if {[info commands ::cmdtype] ne ""} { #hack - look for an alias that may have been specifically enabled to bring this back tailcall ::cmdtype $cmd @@ -1009,9 +1206,23 @@ tcl::namespace::eval punk::ns { } } if {[info commands ::tcl::info::cmdtype] ne ""} { - tailcall info cmdtype $cmd + if {$weird_ns} { + if {[nseval_ifexists $where [list ::info commands $what]] eq ""} { + return notfound + } else { + return [nseval_ifexists $where [list ::tcl::info::cmdtype $what]] + } + } else { + if {[namespace eval $where [list ::info commands $what]] eq ""} { + #e.g parray if it hasn't yet been called (an auto_path loaded command) + return notfound + } else { + tailcall namespace eval $where [list ::tcl::info::cmdtype $what] + } + } } - #we could examine namespaces to determine - but would be duplicating work already done/available in get_ns_dicts which is usually the caller + #we could examine namespaces to determine more - but would be duplicating work already done/available in get_ns_dicts which is usually the caller + #also - we're unlikely to be able to (easily) duplicate the full info cmdtype behaviour - so don't try here! return na } #non-contextual - but impure due to state-retrieval from the passed-in namespace part of the fq_glob @@ -1055,6 +1266,7 @@ tcl::namespace::eval punk::ns { } else { set report_namespaces $matched_namespaces } + punk::args::update_definitions $report_namespaces set nsdict_list [list] foreach ch $report_namespaces { @@ -1085,8 +1297,18 @@ tcl::namespace::eval punk::ns { #JMN set location $ch - set exportpatterns [tcl::namespace::eval $location {::namespace export}] - set nspathlist [tcl::namespace::eval $location {::namespace path}] + set locationparts [nsparts $location] + set weird_ns 0 + if {[lsearch $locationparts :*] >= 0} { + set weird_ns 1 + } + if {$weird_ns} { + set exportpatterns [nseval_ifexists $location {::namespace export}] + set nspathlist [nseval_ifexists $location {::namespace path}] + } else { + set exportpatterns [tcl::namespace::eval $location {::namespace export}] + set nspathlist [tcl::namespace::eval $location {::namespace path}] + } set nspathdict [dict create] if {$nspathcommands} { foreach pathns $nspathlist { @@ -1105,7 +1327,25 @@ tcl::namespace::eval punk::ns { foreach p $exportpatterns { if {[regexp {[*?]} $p]} { #lappend matched {*}[nseval $location [list ::info commands [nsjoin ${location} $p]]] - lappend matched {*}[tcl::namespace::eval $location [list ::info commands [nsjoin ${location} $p]]] + if {$weird_ns} { + #! info commands can't glob with a weird ns prefix + #! info commands with no arguments returns all commands (from global and any other ns in namespace path) + #lappend matched {*}[nseval_ifexists $location [list ::info commands [nsjoin ${location} $p]]] + lappend matched {*}[nseval_ifexists $location [string map [list $location $p] { + set allcommands [info commands] + set matches [list] + foreach c $allcommands { + set fq [namespace which $c] + if {[string match :: $fq]} { + lappend matches $c + } + } + return $matches + }] + + } else { + lappend matched {*}[tcl::namespace::eval $location [list ::info commands [nsjoin ${location} $p]]] + } foreach m $matched { lappend allexported [nstail $m] } @@ -1115,7 +1355,11 @@ tcl::namespace::eval punk::ns { } set allexported [lsort -unique $allexported] #NOTE: info procs within tcl::namespace::eval is different to 'info commands' within tcl::namespace::eval (info procs doesn't look outside of namespace) - set allprocs [tcl::namespace::eval $location {::info procs}] + if {$weird_ns} { + set allprocs [nseval_ifexists $location {::info procs}] + } else { + set allprocs [tcl::namespace::eval $location {::info procs}] + } #set allprocs [nseval $location {::info procs}] set childtails [lmap v $allchildren {nstail $v}] set allaliases [list] @@ -1133,7 +1377,11 @@ tcl::namespace::eval punk::ns { set interp_aliases [interp aliases ""] #use aliases glob - because aliases can be present with or without leading :: #NOTE: alias may not have matching command in the relevant namespce (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases - set raw_aliases [tcl::namespace::eval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + if {$weird_ns} { + set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + } else { + set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + } #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. set aliases [list] foreach a $raw_aliases { @@ -1147,38 +1395,91 @@ tcl::namespace::eval punk::ns { } } + #NOTE for 'info ...' 'namespace origin|(etc)..' + # - use the pattern [namespace eval $location [list $cmd]] + #This allows examination of cmds with "bad" names such as empty string or prefixed with single colon. + #while these should be rare - we want to handle such edge cases when browsing namespaces. foreach cmd $commands { #if {"${location}::$cmd" in $interp_aliases || [string trimleft "${location}::$cmd" ":"] in $interp_aliases} { - # #NOTE: doesn't cater for renamed aliases - Tcl 8.x doesn't seem to have any introspection capabilities to match command to a renamed alias + # #NOTE: doesn't cater for renamed aliases - Tcl 8.x (and 9.01) doesn't seem to have any introspection capabilities to match command to a renamed alias # #which_alias hack from wiki relies on trace and executing the command - which we don't want to do. # lappend allaliases $cmd #} set ctype [cmdtype ${location}::$cmd] switch -- $ctype { na { + if {$weird_ns} { + set cmdorigin [nseval_ifexists $location [list ::namespace origin $cmd]] + } else { + set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] + } + if {[nsprefix $cmdorigin] ne $location} { + #import + lappend allimported $cmd + set origin_location [nsprefix $cmdorigin] + } else { + set origin_location $location + } #tcl 8.6 (info cmdtype unavailable) #todo - use catch tcl::unsupported::corotype to see if coroutine - if {![catch {namespace ensemble configure ${location}::$cmd} ensemble_info]} { - lappend allensembles $cmd - } elseif {[info object isa object ${location}::$cmd]} { - lappend allooobjects $cmd - if {[info object isa class ${location}::$cmd]} { - lappend allooclasses $cmd + set originlocationparts [nsparts $origin_location] + set weird_origin 0 + if {[lsearch $originlocationparts :*] >= 0} { + set weird_origin 1 + } + if {$weird_origin} { + if {![catch {nseval_ifexists $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { + lappend allensembles $cmd + } elseif {[nseval_ifexists $origin_location [list ::info object isa object $cmd]]} { + lappend allooobjects $cmd + if {[nseval_ifexists $origin_location [list ::info object isa class $cmd]]} { + lappend allooclasses $cmd + } + } else { + + } + } else { + if {![catch {namespace eval $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { + lappend allensembles $cmd + } elseif {[namespace eval $origin_location [list ::info object isa object $cmd]]} { + lappend allooobjects $cmd + if {[namespace eval $origin_location [list ::info object isa class $cmd]]} { + lappend allooclasses $cmd + } + } else { + } } } default { - if {$ctype eq "imported"} { - set cmdorigin [namespace origin [nsjoin $location $cmd]] + if {$ctype eq "import"} { + if {$weird_ns} { + set cmdorigin [nseval_ifexists $location [list ::namespace origin $cmd]] + } else { + set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] + } #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source #ie we don't need to follow a chain of 'imported' results. - set mixedtype i-[info cmdtype $cmdorigin] + set origin_location [nsprefix $cmdorigin] + set origin_cmd [nstail $cmdorigin] + + set originlocationparts [nsparts $origin_location] + set weird_origin 0 + if {[lsearch $originlocationparts :*] >= 0} { + set weird_origin 1 + } + if {$weird_origin} { + set mixedtype i-[nseval_ifexists $origin_location [list ::tcl::info::cmdtype $origin_cmd]] + } else { + set mixedtype i-[namespace eval $origin_location [list ::tcl::info::cmdtype $origin_cmd]] + } + lappend allimported $cmd } else { set mixedtype $ctype } - #assert ctype != imported + #assert mixedtype != import #review - we don't have a way to mark as both native and ensemble - switch -- $ctype { + switch -- $mixedtype { i-native - native { lappend allnative $cmd } @@ -1224,7 +1525,7 @@ tcl::namespace::eval punk::ns { } } - #JMN + #JMN TODO if {[catch { if {$cmd eq ""} { #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. @@ -1297,6 +1598,52 @@ tcl::namespace::eval punk::ns { #definitely don't count exportpatterns incr itemcount [llength $undetermined] + set usageinfo [list] + set has_punkargs [expr {[info commands ::punk::args::id_exists] ne ""}] + set has_tepam [expr {[info exists ::tepam::ProcedureList]}] + if {$has_punkargs || $has_tepam} { + foreach c $commands { + if {$c in $imported} { + set fq [namespace origin [nsjoin $location $c]] + } elseif {$c in $aliases} { + #TODO - use which_alias ? + set tgt [interp alias "" [nsjoin $location $c]] + if {$tgt eq ""} { + set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] + } + set word1 [lindex $tgt 0] + if {$word1 eq "punk::mix::base::_cli"} { + #special case for punk deck - REVIEW + #e.g punk::mix::base::_cli -extension ::punk::mix::cli + set fq [lindex $tgt end] ;#todo - explicitly get -extension argval in case _cli extended with other options + } else { + #todo - alias may have prefilled some leading args - so usage report should reflect that??? + #(currying) + set fq $word1 + } + } else { + set fq [nsjoin $location $c] + } + if {$has_punkargs} { + #set id [string trimleft $fq :] + set id $fq + punk::args::update_definitions [list [namespace qualifiers $id]] + if {[::punk::args::id_exists $id]} { + lappend usageinfo $c + } else { + if {$has_tepam} { + if {$fq in $::tepam::ProcedureList} { + lappend usageinfo $c + } + } + } + } else { + if {$fq in $::tepam::ProcedureList} { + lappend usageinfo $c + } + } + } + } set nsdict [dict create\ location $location\ @@ -1317,6 +1664,7 @@ tcl::namespace::eval punk::ns { ooprivateclasses $ooprivateclasses\ namespacexport $exportpatterns\ undetermined $undetermined\ + usageinfo $usageinfo\ namespacepath $nspathdict\ glob $glob\ itemcount $itemcount\ @@ -1462,11 +1810,33 @@ tcl::namespace::eval punk::ns { ::set what $search } } - - ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] + set weird_ns 0 + if {[string match *:::* $base]} { + set weird_ns 1 + } #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created - ::if {![::tcl::namespace::exists $base]} { - ::continue + if {$weird_ns} { + ::if {![nsexists $base]} { + ::continue + } + #info commands can't glob with weird_ns prefix + puts ">>> base: $base what: $what" + ::set all_ns_commands [nseval_ifexists $base [list apply {{loc what} { + set _all [uplevel 1 [list ::info commands]] + set _matches [list] + foreach _a $_all { + set _c [uplevel 1 [list ::namespace which $_a]] + if {[::string match ${loc}::${what} $_c]} { + ::lappend _matches $_a + } + } + return $_matches + }} $base $what ]] + } else { + ::if {![::tcl::namespace::exists $base]} { + ::continue + } + ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] } ::set all_ns_tails [::lmap v $all_ns_commands {::punk::ns::nstail $v}] foreach c $all_ns_tails { @@ -1531,6 +1901,764 @@ tcl::namespace::eval punk::ns { } } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} = 0} { + #use nseval_ifexists to avoid creating intermediate namespaces for bogus paths + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + }]} { + set origin $querycommand + set resolved $querycommand + } + } else { + #fully qualified command specified but doesn't exist + set origin $querycommand + set resolved $querycommand + } + } else { + #relative comandpath + if {[string match (autodef)* $querycommand]} { + #pass through - should be found with id lookup + set origin $querycommand + set resolved $querycommand + } else { + set thispath [uplevel 1 [list ::nsthis $querycommand]] + set targetns [nsprefix $thispath] + set name [nstail $thispath] + set targetparts [nsparts $targetns] + if {[lsearch $targetparts :*] >=0} { + #weird ns + set valid_ns [nsexists $targetns] + } else { + set valid_ns [namespace exists $targetns] + } + if {$valid_ns} { + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + }]} { + set thiscmd [nsjoin $targetns $name] + #relative querycommand specified - but Tcl didn't find a match in namespace path + #assume global (todo - look for namespace match in auto_index first ?) + set origin ::$name + set resolved ::$name + } + } else { + #namespace as relative to current doesn't seem to exist + #Tcl would also attempt to resolve as global + + #set numvals [expr {[llength $queryargs]+1}] + ##puts "THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]" + #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]] + return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] + + #set origin $querycommand + #set resolved $querycommand + + } + } + } + + #check for a direct match first + if {[info commands ::punk::args::id_exists] ne ""} { + if {![llength $queryargs]} { + punk::args::update_definitions [list [namespace qualifiers $origin]] + if {[punk::args::id_exists $origin]} { + return [uplevel 1 [list punk::args::usage {*}$opts $origin]] + } + } + } + + #ns::cmdtype only detects alias type on 8.7+? + set initial_cmdtype [punk::ns::cmdtype $origin] + switch -- $initial_cmdtype { + na - alias { + #REVIEW - alias entry doesn't necessarily match command! + #consider using which_alias (wiki) + set tgt [interp alias "" $origin] + if {$tgt eq ""} { + set tgt [interp alias "" [string trimleft $origin :]] + } + #first word of tgt may be namespace relative or absolute + if {$tgt ne ""} { + set word1 [lindex $tgt 0] + if {$word1 eq "punk::mix::base::_cli"} { + #special case for punk deck - REVIEW + #e.g punk::mix::base::_cli -extension ::punk::mix::cli + set targetword [lindex $tgt end] + } else { + #todo - alias may have prefilled some leading args - so usage report should reflect that??? + #(possible curried arguments) + #review - curried arguments could be for ensembles! + set targetword $word1 + #set numvals [expr {[llength $queryargs]+1}] + #puts "ALIAS THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]" + #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + return [namespace eval :: [list punk::ns::arginfo {*}$opts $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + } + + + set origin $targetword + #retest cmdtype on modified origin + set cmdtype [punk::ns::cmdtype $origin] + } else { + set cmdtype $initial_cmdtype + } + if {$cmdtype eq "na"} { + #tcl 8.6 + if {[info object isa object $origin]} { + set cmdtype "object" + } + } + } + default { + set cmdtype $initial_cmdtype + } + } + + + set id $origin + if {[info commands ::punk::args::id_exists] ne ""} { + + + #check longest first checking for id matching ::cmd ?subcmd..? + #REVIEW - this doesn't cater for prefix callable subcommands + set argcopy $queryargs + if {[llength $queryargs]} { + punk::args::update_definitions [list [namespace qualifiers $id]] + if {[punk::args::id_exists [list $id {*}$queryargs]]} { + return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + } + } + #while {[llength $argcopy]} { + # if {[punk::args::id_exists [list $id {*}$argcopy]]} { + # return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$argcopy]]] + # } + # lpop argcopy + #} + + #didn't find any exact matches + #traverse from other direction taking prefixes into account + + punk::args::update_definitions [list [namespace qualifiers $id]] + if {[punk::args::id_exists $id]} { + #cycle forward through leading values + set spec [punk::args::get_spec $id] + if {[llength $queryargs]} { + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + foreach q $queryargs { + if {[llength [dict get $spec LEADER_NAMES]]} { + set subitems [dict get $spec LEADER_NAMES] + if {[llength $subitems]} { + set next [lindex $subitems 0] + set arginfo [dict get $spec ARG_INFO $next] + + set allchoices [list] + set choices [punk::args::system::Dict_getdef $arginfo -choices {}] + set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices {*}$clist + } + set resolved_q [tcl::prefix::match -error "" $allchoices $q] + if {$resolved_q eq ""} { + break + } + lappend nextqueryargs $resolved_q + lpop queryargs_untested 0 + if {$resolved_q ne $q} { + #we have our first difference - recurse with new query args + #set numvals [expr {[llength $queryargs]+1}] + #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] + #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" + return [ punk::ns::arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested] + + } + #check if subcommands so far have a custom args def + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list $id {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set spec [punk::args::get_spec $currentid] + } else { + #We can get no further with custom defs + #It is possible we have a documented lower level subcommand but missing the intermediate + #e.g if ::trace remove command was specified and is documented - it will be found above + #but if ::trace remove is not documented and the query is "::trace remove com" + #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. + #that's probably ok. + break + } + } + } else { + #review + break + } + } + } else { + return [uplevel 1 [list punk::args::usage {*}$opts $id]] + } + } + } + + if {[string match "(autodef)*" $origin]} { + #wasn't resolved by id - so take this as a request to generate it (probably there is an existing custom def - and this has been manually requested to get the default) + set origin [string range $origin [string length (autodef)] end] + set resolved $origin + } + + switch -- $cmdtype { + object { + #class is also an object + #todo -mixins etc etc + set class [info object class $origin] + #the call: info object methods -all + # seems to do the right thing as far as hiding unexported methods, and showing things like destroy + # - which don't seem to be otherwise easily introspectable + set public_methods [info object methods $origin -all] + #set class_methods [info class methods $class] + #set object_methods [info object methods $origin] + + if {[llength $queryargs]} { + set c1 [lindex $queryargs 0] + if {$c1 in $public_methods} { + switch -- $c1 { + new { + set constructorinfo [info class constructor $origin] + set arglist [lindex $constructorinfo 0] + set argdef [punk::lib::tstr -return string { + @id -id "(autodef)${$origin} new" + @cmd -name "${$origin} new" -help\ + "create object with specified command name. + Arguments are passed to the constructor." + @values + }] + set i 0 + foreach a $arglist { + if {[llength $a] == 1} { + if {$i == [llength $arglist]-1 && $a eq "args"} { + #'args' is only special if last + append argdef \n "args -optional 1 -multiple 1" + } else { + append argdef \n "$a" + } + } else { + append argdef \n "[lindex $a 0] -default [lindex $a 1]" + } + incr i + } + punk::args::define $argdef + return [punk::args::usage {*}$opts "(autodef)$origin new"] + } + create { + set constructorinfo [info class constructor $origin] + set arglist [lindex $constructorinfo 0] + set argdef [punk::lib::tstr -return string { + @id -id "(autodef)${$origin} create" + @cmd -name "${$origin} create" -help\ + "create object with specified command name. + Arguments following objectName are passed to the constructor." + @values -min 1 + objectName -type string -help\ + "possibly namespaced name for object instance command" + }] + set i 0 + foreach a $arglist { + if {[llength $a] == 1} { + if {$i == [llength $arglist]-1 && $a eq "args"} { + #'args' is only special if last + append argdef \n "args -optional 1 -multiple 1" + } else { + append argdef \n "$a" + } + } else { + append argdef \n "[lindex $a 0] -default [lindex $a 1]" + } + incr i + } + punk::args::define $argdef + return [punk::args::usage {*}$opts "(autodef)$origin create"] + } + destroy { + #review - generally no doc + # but we may want notes about a specific destructor + set argdef [punk::lib::tstr -return string { + @id -id "(audodef)${$origin} destroy" + @cmd -name "destroy" -help\ + "delete object, calling destructor if any. + destroy accepts no arguments." + @values -min 0 -max 0 + }] + punk::args::define $argdef + return [punk::args::usage {*}$opts "(autodef)$origin destroy"] + } + default { + #use info object call to resolve callchain + #we assume the first impl is the topmost in the callchain + # and its call signature is therefore the one we are interested in - REVIEW + # we should probably ignore generaltypes filter|unknown and look for a subsequent method|private? + set implementations [::info object call $origin $c1] + #result documented as list of 4 element lists + #set callinfo [lindex $implementations 0] + set oodef "" + foreach impl $implementations { + lassign $impl generaltype mname location methodtype + switch -- $generaltype { + method - private { + #objects being dynamic systems - we should always reinspect. + #Don't use the cached (autodef) def + #If there is a custom def override - use it (should really be -dynamic - but we don't check) + if {$location eq "object"} { + set idcustom "$origin $c1" + #set id "[string trimleft $origin :] $c1" ;# " " + if {[info commands ::punk::args::id_exists] ne ""} { + if {[punk::args::id_exists $idcustom]} { + return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] + } + } + set oodef [::info object definition $origin $c1] + } else { + #set id "[string trimleft $location :] $c1" ;# " " + set idcustom "$location $c1" + if {[info commands ::punk::args::id_exists] ne ""} { + if {[punk::args::id_exists $idcustom]} { + return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] + } + } + set oodef [::info class definition $location $c1] + } + break + } + filter { + } + unknown { + } + } + } + if {$oodef ne ""} { + set autoid "(autodef)$location $c1" + set arglist [lindex $oodef 0] + set argdef [punk::lib::tstr -return string { + @id -id "${$autoid}" + @cmd -name "${$location} ${$c1}" -help\ + "(autogenerated) + arglist:${$arglist}" + @values + }] + set i 0 + foreach a $arglist { + switch -- [llength $a] { + 1 { + if {$i == [llength $arglist]-1 && $a eq "args"} { + #'args' is only special if last + append argdef \n "args -optional 1 -multiple 1" + } else { + append argdef \n "$a" + } + } + 2 { + append argdef \n "[lindex $a 0] -default {[lindex $a 1]} -optional 1" + } + default { + error "punk::ns::arginfo unexpected oo argument signature '$arglist'\noodef:$oodef\nimplementations:$implementations" + } + } + incr i + } + punk::args::define $argdef + return [punk::args::usage {*}$opts $autoid] + } else { + return "unable to resolve $origin method $c1" + } + + } + } + } + } + set choicelabeldict [dict create] + foreach cmd $public_methods { + switch -- $cmd { + new - create - destroy { + #todo + } + default { + set implementations [::info object call $origin $cmd] + set def "" + foreach impl $implementations { + lassign $impl generaltype mname location methodtype + switch -- $generaltype { + method - private { + if {$location eq "object"} { + #set id "[string trimleft $origin :] $cmd" ;# " " + set id "$origin $cmd" + } else { + #set id "[string trimleft $location :] $cmd" ;# " " + set id "$location $cmd" + } + if {[info commands ::punk::args::id_exists] ne ""} { + if {[punk::args::id_exists $id]} { + dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + } + } + break + } + filter { + } + unknown { + } + } + } + } + } + } + + set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceprefix 0] ;#methods must be specified in full always? - review + #puts stderr "--->$vline" + set idauto "(autodef)$origin" + set argdef [punk::lib::tstr -return string { + @id -id ${$idauto} + @cmd -name "Object: ${$origin}" -help\ + "Instance of class: ${$class} (info autogenerated)" + @leaders -min 1 + }] + append argdef \n $vline + punk::args::define $argdef + return [punk::args::usage {*}$opts $idauto] + } + privateObject { + return "Command is a privateObject - no info currently available" + } + privateClass { + return "Command is a privateClass - no info currently available" + } + interp { + #todo + } + } + + #check ensemble before testing punk::arg::id_exists + #we want to recalculate ensemble usage info in case ensemble has been modified + + if {[namespace ensemble exists $origin]} { + #review + #todo - check -unknown + #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. + #presumably -choiceprefix should be zero in that case?? + + set ensembleinfo [namespace ensemble configure $origin] + set prefixes [dict get $ensembleinfo -prefixes] + set map [dict get $ensembleinfo -map] + set ns [dict get $ensembleinfo -namespace] + + #review - we can have a combination of commands from -map as well as those exported from -namespace + # if and only if -subcommands is specified + + set subcommand_dict [dict create] + set commands [list] + set nscommands [list] + if {[llength [dict get $ensembleinfo -subcommands]]} { + #set exportspecs [namespace eval $ns {namespace export}] + #foreach pat $exportspecs { + # lappend nscommands {*}[info commands ${ns}::$pat] + #} + #when using -subcommands, even unexported commands are available + set nscommands [info commands ${ns}::*] + foreach sub [dict get $ensembleinfo -subcommands] { + if {[dict exists $map $sub]} { + #-map takes precence over same name exported from -namespace + dict set subcommand_dict $sub [dict get $map $sub] + } elseif {"${ns}::$sub" in $nscommands} { + dict set subcommand_dict $sub ${ns}::$sub + } else { + #subcommand probably supplied via -unknown handler? + dict set subcommand_dict $sub "" + } + } + } else { + if {[dict size $map]} { + set subcommand_dict $map + } else { + set exportspecs [namespace eval $ns {namespace export}] + foreach pat $exportspecs { + lappend nscommands {*}[info commands ${ns}::$pat] + } + foreach fqc $nscommands { + dict set subcommand_dict [namespace tail $fqc] $fqc + } + } + } + + + set subcommands [lsort [dict keys $subcommand_dict]] + if {[llength $queryargs]} { + set match [tcl::prefix::match $subcommands [lindex $queryargs 0]] + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + return [arginfo {*}$opts {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + } + } + + set namespaces [list] ;# usually only 1 or 2 namespaces - but could be any number. + dict for {sub subwhat} $subcommand_dict { + set ns [::namespace which $subwhat] + if {$ns ni $namespaces} { + lappend namespaces $ns + } + } + set have_usageinfo [list] + set is_ensemble [list] + set is_object [list] + foreach ns $namespaces { + set nsinfo [lindex [punk::ns::nslist_dict [nsjoin [nsprefix $ns] *]] 0] + lappend have_usageinfo {*}[dict get $nsinfo usageinfo] + lappend is_ensemble {*}[dict get $nsinfo ensembles] + lappend is_object {*}[dict get $nsinfo ooobjects] + } + + set choicelabeldict [dict create] + foreach sub $subcommands { + if {$sub in $have_usageinfo} { + dict set choicelabeldict $sub " [Usageinfo_mark brightgreen]" + } elseif {$sub in $is_ensemble} { + dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" + } elseif {$sub in $is_object} { + dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" + } + } + + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] + set autoid "(autodef)$origin" + set argdef [punk::lib::tstr -return string { + @id -id ${$autoid} + @cmd -help\ + "(autogenerated) + ensemble: ${$origin}" + @leaders -min 1 + }] + append argdef \n $vline + punk::args::define $argdef + return [punk::args::usage {*}$opts $autoid] + } + + #check for tepam help + if {[info exists ::tepam::ProcedureList]} { + if {$origin in $::tepam::ProcedureList} { + return [tepam::ProcedureHelp $origin 1] ;#use 1 to return rather than emit to stdout + } else { + #handle any tepam functions that don't eat their own dogfood but have help variables + #e.g tepam::procedure, tepam::argument_dialogbox + #Rather than hardcode these - we'll guess that any added will use the same scheme.. + if {[namespace qualifiers $origin] eq "::tepam"} { + set func [namespace tail $origin] + #tepam XXXHelp vars don't exactly match procedure names :/ + if {[info exists ::tepam::${func}Help]} { + return [set ::tepam::${func}Help] + } else { + set f2 [string totitle $func] + if {[info exists ::tepam::${f2}Help]} { + return [set ::tepam::${f2}Help] + } + #e.g argument_dialogbox -> ArgumentDialogboxHelp + set parts [split $func _] + set uparts [lmap p $parts {string totitle $p}] + set f3 [join [list {*}$uparts Help] ""] + if {[info exists ::tepam::${f3}]} { + return [set ::tepam::${f3}] + } + } + } + } + } + + set origin_ns [nsprefix $origin] + set parts [nsparts $origin_ns] + set weird_ns 0 + if {[lsearch $parts :*] >=0} { + set weird_ns 1 + } + if {$weird_ns} { + set argl {} + set tail [nstail $origin] + set cmdtype [nseval_ifexists $origin_ns [list punk::ns::cmdtype $tail]] + if {$cmdtype eq "proc"} { + foreach a [nseval_ifexists $origin_ns [list info args $tail]] { + if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { + lappend a $def + } + lappend argl $a + } + } + } else { + set cmdtype [punk::ns::cmdtype $origin] + if {$cmdtype eq "proc"} { + set argl {} + set infoargs [info args $origin] + foreach a $infoargs { + if {[info default $origin $a def]} { + lappend a $def + } + lappend argl $a + } + } + } + + if {[llength $queryargs]} { + #todo - something better + set msg "Undocumented or nonexistant subcommand $origin $queryargs" + append msg \n "$origin Type: $cmdtype" + } else { + if {$cmdtype eq "proc"} { + set msg "Undocumented proc $origin" + append msg \n "No argument processor detected" + append msg \n "function signature: $resolved $argl" + } else { + set msg "Undocumented command $origin. Type: $cmdtype" + } + } + return $msg + } + #todo - package up as navns proc corp {path} { #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp @@ -1549,6 +2677,8 @@ tcl::namespace::eval punk::ns { set body "" } + #we want to handle edge cases of commands such as "" or :x + #various builtins such as 'namespace which' won't work if {[string match ::* $path]} { set targetns [nsprefix $path] set name [nstail $path] @@ -1561,7 +2691,8 @@ tcl::namespace::eval punk::ns { #set name [string trim $name :] #set origin [namespace origin ${upns}::$name] - set origin [nseval $targetns [list ::namespace origin $name]] + set origin [nseval $targetns [list ::namespace origin $name]] + set resolved [nseval $targetns [list ::namespace which $name]] #An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! if {$origin ni [info procs $origin]} { @@ -1613,7 +2744,8 @@ tcl::namespace::eval punk::ns { } lappend argl $a } - list proc [nsjoin ${targetns} $name] $argl $body + #list proc [nsjoin ${targetns} $name] $argl $body + list proc $resolved $argl $body } @@ -1689,7 +2821,8 @@ tcl::namespace::eval punk::ns { proc _pkguse_vars {varnames} { while {"pkguse_vars_[incr n]" in $varnames} {} - return [concat $varnames pkguse_vars_$n] + #return [concat $varnames pkguse_vars_$n] + return [list {*}$varnames pkguse_vars_$n] } proc tracehandler_nowrite {args} { error "readonly in use block" @@ -1705,6 +2838,7 @@ tcl::namespace::eval punk::ns { lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs set use_vars [expr {"-vars" in $runopts}] set no_warnings [expr {"-nowarnings" in $runopts}] + set ver "" #todo support leading solo flags such as -capture to control whether we do a static capture of local vars in the ns @@ -1715,15 +2849,68 @@ tcl::namespace::eval punk::ns { } default { if {[string match ::* $pkg_or_existing_ns]} { + set pkg_unqualified [string range $pkg_or_existing_ns 2 end] if {![tcl::namespace::exists $pkg_or_existing_ns]} { - set ver [package require [string range $pkg_or_existing_ns 2 end]] + set ver [package require $pkg_unqualified] } else { set ver "" } set ns $pkg_or_existing_ns } else { - set ver [package require $pkg_or_existing_ns] - set ns ::$pkg_or_existing_ns + set pkg_unqualified $pkg_or_existing_ns + set ver [package require $pkg_unqualified] + set ns ::$pkg_unqualified + } + #some packages don't create their namespace immediately and/or don't populate it with commands and instead put entries in ::auto_index + set previous_command_count 0 + if {[namespace exists $ns]} { + set previous_command_count [llength [info commands ${ns}::*]] + } + + + #also if a sub package was loaded first - then the namespace for the base or lower package may exist but have no commands + #for the purposes of pkguse - which most commonly interactive - we want the namespace populated + #It may still not be *fully* populated because we stop at first source that adds commands - REVIEW + set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}] + + if {!$ns_populated} { + #we will catch-run an auto_index entry if any + #auto_index entry may or may not be prefixed with :: + set keys [list] + #first look for exact pkg_unqualified and ::pkg_unqualified + #leave these at beginning of keys list + if {[array exists ::auto_index($pkg_unqualified)]} { + lappend keys $pkg_unqualified + } + if {[array exists ::auto_index(::$pkg_unqualified)]} { + lappend keys ::$pkg_unqualified + } + #as auto_index is an array - we could get keys in arbitrary order + set matches [lsort [array names ::auto_index ${pkg_unqualified}::*]] + lappend keys {*}$matches + set matches [lsort [array names ::auto_index ::${pkg_unqualified}::*]] + lappend keys {*}$matches + set ns_populated 0 + set i 0 + set already_sourced [list] ;#often multiple triggers for the same source - don't waste time re-sourcing + set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]] + while {!$ns_populated && $i < [llength $keys]} { + #todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base + #e.g if we are loading ::x::y + #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc + set k [lindex $keys $i] + set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]] + if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} { + set auto_source [set ::auto_index($k)] + if {$auto_source ni $already_sourced} { + uplevel 1 $auto_source + lappend already_sourced $auto_source + set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}] + } + } + incr i + } + } } } @@ -1797,63 +2984,128 @@ tcl::namespace::eval punk::ns { return $out } } else { - error "Namespace $ns not found." + if {$ver eq ""} { + error "Namespace $ns not found. No package version found." + } else { + set out "(no package namespace found) remaining in [uplevel 1 {namespace current}]" + append out \n $ver + return $out + } } return $out } interp alias "" use "" punk::ns::pkguse + punk::args::define { + @id -id ::punk::ns::nsimport_noclobber + @cmd -name punk::ns::nsimport_noclobber -help\ + "Import exported commands from a namespace into either the current namespace, + or that specified in -targetnamespace. + Return list of imported commands, ignores failures due to name conflicts" + -targetnamespace -optional 1 -help\ + "Namespace in which to import commands. + If namespace is relative (no leading ::), + the namespace is relative to the caller'd namespace. + If not supplied, caller's namespace is used." + -prefix -optional 1 -help\ + "string prefix for command names in target namespace" + @values -min 1 -max -1 + sourcepattern -type string -optional 0 -multiple 1 -help\ + "Glob pattern(s) for exported commands in source namespace(s). + Globbing only active in the tail segment. + e.g ::mynamespace::a* ::mynamespace::j*" + } proc nsimport_noclobber {args} { - set argspecs { - -targetnamespace -default "" -optional 1 - -prefix -default "" -optional 1 - *values -min 1 -max 1 - sourcepattern -type string -optional 0 - } - lassign [dict values [punk::args::get_dict $argspecs $args]] opts values - set sourcepattern [dict get $values sourcepattern] + lassign [dict values [punk::args::get_by_id ::punk::ns::nsimport_noclobber $args]] leaders opts values received + set sourcepatterns [dict get $values sourcepattern] - set source_ns [tcl::namespace::qualifiers $sourcepattern] - if {![tcl::namespace::exists $source_ns]} { - error "nsimport_noclobber error namespace $source_ns not found" - } - set target_ns [dict get $opts -targetnamespace] set nscaller [uplevel 1 {namespace current}] - if {$target_ns eq ""} { + if {![dict exists $received -targetnamespace]} { set target_ns $nscaller - } elseif {![string match ::* $target_ns]} { - set target_ns [punk::nsjoin $nscaller $target_ns] - } - - set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] - set a_commands [info commands $sourcepattern] - set a_tails [lmap v $a_commands {tcl::namespace::tail $v}] - set a_exported_tails [list] - foreach epattern $a_export_patterns { - set matches [lsearch -all -inline $a_tails $epattern] - foreach m $matches { - if {$m ni $a_exported_tails} { - lappend a_exported_tails $m + } else { + set target_ns [dict get $opts -targetnamespace] + if {![string match ::* $target_ns]} { + set target_ns [punk::ns::nsjoin $nscaller $target_ns] + } + } + set all_imported [list] + set nstemp ::punk::ns::temp_import + + foreach pat $sourcepatterns { + set source_ns [tcl::namespace::qualifiers $pat] + if {![tcl::namespace::exists $source_ns]} { + error "nsimport_noclobber error namespace $source_ns not found" + } + + set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] + set a_commands [info commands $pat] + #puts "-->commands:'$a_commands'" + set a_tails [lmap v $a_commands {tcl::namespace::tail $v}] + set a_exported_tails [list] + foreach epattern $a_export_patterns { + set matches [lsearch -all -inline $a_tails $epattern] + foreach m $matches { + #we will be using namespace import one by one on commands. + #we must protect glob chars that may exist in the actual command names. + #e.g nsimport_noclobber ::punk::ansi::a? + # will import a+ and a? + #but nsimport_noclobber {::punk::ansi::a\?} + # must import only a? + set m [string map {\\ \\\\ ? \\? * \\* \[ \\[ \] \\]} $m] + if {$m ni $a_exported_tails} { + lappend a_exported_tails $m + } } } - } - set imported_commands [list] - foreach e $a_exported_tails { - set imported [tcl::namespace::eval $target_ns [string map [list $e $source_ns] { - set cmd "" - if {![catch {namespace import ::}]} { - set cmd + + + if {[tcl::dict:::exists $received -prefix]} { + #import via temporary/intermediate namespace + set pfx [dict get $opts -prefix] + set imported_commands [list] + if {[namespace exists $nstemp]} { + namespace delete $nstemp + } + namespace eval $nstemp {} + foreach e $a_exported_tails { + set imported [apply {{tgtns func srcns pfx tmpns} { + set cmd "" + if {![catch {::tcl::namespace::eval $tmpns [list ::namespace import ${srcns}::$func]}]} { + #renaming will fail if target already exists + #renaming a command into another namespace still results in a command with 'info cmdtype' = 'import' + if {![catch {::tcl::namespace::eval $tmpns [list ::rename $func [::punk::ns::nsjoin $tgtns $pfx$func]]}]} { + set cmd $pfx$func + } + } + set cmd + } } $target_ns $e $source_ns $pfx $nstemp] + if {$imported ne ""} { + lappend imported_commands $imported + } + } + namespace delete $nstemp + } else { + #no prefix - direct import + set imported_commands [list] + foreach e $a_exported_tails { + set imported [apply {{tgtns func srcns} { + set cmd "" + if {![catch {tcl::namespace::eval $tgtns [list namespace import ${srcns}::$func]}]} { + set cmd $func + } + set cmd + } } $target_ns $e $source_ns] + if {$imported ne ""} { + lappend imported_commands $imported + } } - set cmd - }]] - if {[string length $imported]} { - lappend imported_commands $imported } + lappend all_imported {*}$imported_commands } - return $imported_commands + return $all_imported } - #todo - use ns::nsimport_noclobber instead + #todo - use ns::nsimport_noclobber instead ? interp alias {} nsthis {} punk::ns::nspath_here_absolute interp alias {} nsorigin {} apply {ns {namespace origin [uplevel 1 ::punk::ns::nspath_here_absolute $ns]} ::} @@ -1862,6 +3114,7 @@ tcl::namespace::eval punk::ns { interp alias {} nsprefix {} punk::ns::nsprefix interp alias {} nstail {} punk::ns::nstail interp alias {} nsparts {} punk::ns::nsparts + interp alias {} nschildren {} punk::ns::nschildren interp alias {} nstree {} punk::ns::nstree #namespace/command/proc query interp alias {} nslist {} punk::ns::nslist @@ -1885,8 +3138,25 @@ tcl::namespace::eval punk::ns { interp alias {} corp {} punk::ns::corp - - + interp alias {} i {} punk::ns::arginfo + + #An example of using punk::args in a pipeline + punk::args::define { + @id -id ::i+ + @cmd -name "i+" -help\ + "Display command help side by side" + @values + cmds -multiple 1 -help\ + "Command names for which to show help info" + } + interp alias {} i+ {}\ + .=args> punk::args::get_by_id ::i+ |argd>\ + .=>2 dict get values cmds |cmds>\ + .=cmds>2 lmap c {i -return tableobject {*}$c} |objs>\ + .=objs>2 lmap t {$t configure -show_vseps 0 -show_edge 1} |>\ + .=objs>2 lmap t {$t print} |tables>\ + .=objs>2 lmap t {$t destroy} |>\ + .=tables>* textblock::join -- -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) 2024 +# +# @@ Meta Begin +# Application punk::packagepreference 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::packagepreference 0 0.1.0] +#[copyright "2024"] +#[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] +#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] +#[require punk::packagepreference] +#[keywords module package] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::packagepreference +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::packagepreference +#[list_begin itemized] + +package require Tcl 8.6- +package require commandstack +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {commandstack}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::packagepreference::class { + #*** !doctools + #[subsection {Namespace punk::packagepreference::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::packagepreference { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + + variable PUNKARGS + + #*** !doctools + #[subsection {Namespace punk::packagepreference}] + #[para] Core API functions for punk::packagepreference + #[list_begin definitions] + + lappend PUNKARGS [list { + @id -id ::punk::packagepreference::install + @cmd -name ::punk::packagepreference::install -help\ + "Install override for ::package builtin - for 'require' subcommand only." + @values -min 0 -max 0 + }] + proc uninstall {} { + #*** !doctools + #[call [fun uninstall]] + #[para]Return to the previous ::package implementation (This will be the builtin if no other override was present when install was called) + + commandstack::remove_rename {::package punk::packagepreference} + } + + lappend PUNKARGS [list { + @id -id ::punk::packagepreference::install + @cmd -name ::punk::packagepreference::install -help\ + "Install override for ::package builtin - for 'require' subcommand only." + @values -min 0 -max 0 + }] + proc install {} { + #*** !doctools + #[call [fun install]] + #[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules + #[para](todo - check info loaded and restrict to existing version as determined from dll/so?) + #[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase. + #[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names" + #[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md + #[para]It prevents some loading errors when multiple package versions are available to an interpreter and the latest version is only provided by a lowercased module (.tm file) + #[para]A package provided by the standard pkgIndex.tcl mechanism might override a later-versioned package because it may support both upper and lowercased names. + #[para]The overriding of ::package only looks at 'package require' calls and preferentially tries the lowercase version (if the package isn't already loaded with either upper or lowercase name) + #[para]This comes at some slight cost for packages that are only available with uppercase letters in the name - but at minimal cost for recommended lowercase package names + #[para]Return to the standard ::package builtin by calling punk::packagepreference::uninstall + + #todo - review/update commandstack package + #modern module/lib names should preferably be lower case + #see tip 590 - "Recommend lowercase Package names". Where non-lowercase are deprecated (but not removed even in Tcl9) + #Mixed case causes problems esp on windows where we can't have Package.tm and package.tm as they aren't distinguishable. + #We enforce package to try lowercase first - at some potentially significant speed penalty if the lib actually does use uppercase + #(also just overloading the package builtin comes at a cost!) + #Without the lowercase-first mechanism - a lower versioned package such as Tablelist provided by a pkgIndex.tcl may be loaded in precedence to a higher versioned tablelist provided by a .tm + #As punk kits launched with dev first arg may use tcl::tm::paths coming from both the system and zipkits for example - this is a problem. + #(or in any environment where multiple versions of Tcl libraries may be available) + #We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file. + #It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective. + set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} { + #::package override installed by punk::packagepreference::install + #return to previous 'package' implementation with: punk::packagepreference::uninstall + + #uglier but faster than tcl::prefix::match in this instance + #maintenance - check no prefixes of require are added to builtin package command + switch -exact -- [lindex $args 0] { + r - re - req - requi - requir - require { + #puts "==>package $args" + #puts "==>[info level 1]" + #despite preference for lowercase - we need to handle packages that insist on providing as uppercase + #(e.g we will still need to handle things like: package provide Tcl 8.6) + #Where the package is already provided uppercase we shouldn't waste time deferring to lowercase + set is_exact 0 + if {[lindex $args 1] eq "-exact"} { + set pkg [lindex $args 2] + set vwant [lindex $args 3]-[lindex $args 3] + set is_exact 1 + } else { + set pkg [lindex $args 1] + set vwant [lrange $args 2 end] ;#rare - but version can be a list of options + if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { + #only one version - and it has a dash + lassign [split [lindex $vwant 0] -] a b + if {$a eq $b} { + #string compare version nums (can contain dots and a|b) + set is_exact 1 + } + } + } + if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { + #although we could shortcircuit using vsatisfies to return the ver + #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. + #e.g a package require logger further down the commandstack + return [$COMMANDSTACKNEXT {*}$args] + } + + if {!$is_exact && [llength $vwant] <= 1 } { + #required version unspecified - or specified singularly + set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg] + if {[llength $available_versions] > 1} { + # --------------------------------------------------------------- + #An attempt to detect dll/so loaded and try to load same version + #dll/so files are often named with version numbers that don't contain dots or a version number at all + #e.g sqlite3400.dll Thread288.dll + set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg] + + if {[llength $pkgloadedinfo]} { + puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" + lassign $pkgloadedinfo path name + set lcpath [string tolower $path] + #first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement. + set lcpath_to_version [dict create] + foreach av $available_versions { + set scr [package ifneeded $pkg $av] + #ifneeded script not always a valid tcl list + if {![catch {llength $scr} scrlen]} { + if {$scrlen == 3 && [lindex $scr 0] eq "load" && [string match -nocase [lindex $scr 2] $pkg]} { + dict set lcpath_to_version [string tolower [lindex $scr 1]] $av + } + } + } + + if {[dict exists $lcpath_to_version $lcpath]} { + set lversion [dict get $lcpath_to_version $lcpath] + } else { + #fallback to a best effort guess based on the path + set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg] + } + if {$lversion ne ""} { + #name matches pkg + #hack for known dll version mismatch + if {[string tolower $pkg] eq "thread" && $lversion eq "30b3"} { + set lversion 3.0b3 + } + if {[llength $vwant] == 1} { + #todo - still check vsatisfies - report a conflict? review + } + return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] + } + } + } + } + # --------------------------------------------------------------- + set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg] + + if {[regexp {[A-Z]} $pkg]} { + #only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation + if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} { + return [$COMMANDSTACKNEXT require $pkg {*}$vwant] + } else { + return $v + } + } else { + return [$COMMANDSTACKNEXT require $pkg {*}$vwant] + } + } + default { + return [$COMMANDSTACKNEXT {*}$args] + } + } + + }] + if {[dict get $stackrecord implementation] ne ""} { + set impl [dict get $stackrecord implementation] ;#use hardcoded name rather than slower (but more flexible) commandstack::get_next_command + #puts stdout "punk::packagepreference renamed ::package to $impl" + return 1 + } else { + puts stderr "punk::packagepreference failed to rename ::package" + return 0 + } + #puts stdout [info body ::package] + } + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::packagepreference ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::packagepreference::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::packagepreference::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::packagepreference::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::packagepreference::system { + #*** !doctools + #[subsection {Namespace punk::packagepreference::system}] + #[para] Internal functions that are not part of the API + variable PUNKARGS + + lappend PUNKARGS [list { + @id -id ::punk::packagepreference::system::slibpath_guess_pkgversion + @cmd -name punk::packagepreference::system::slibpath_guess_pkgversion -help\ + "Assistance function to determine pkg version from the information + obtained from [info loaded]. This is used to try to avoid loading a different + version of a binary package in another thread/interp when the package isn't + present in the interp, but [info loaded] indicates the binary is already loaded. + The more general/robust way to avoid this is to ensure ::auto_path and + tcl::tm::list are the same in each interp/thread. + + This call should only be used as a fallback in case a binary package has a more + complex ifneeded script. If the ifneeded script for a binary package is a + straightforward 'load ' - then that information + should be used to determine the version by matching + rather than this one. + + Takes a path to a shared lib (.so/.dll), and the name of its providing + package, and return the version of the package if possible to determine + from the path. + The filename portion of the lib is often missing a version number or has + a version number that has been shortened (e.g dots removed). + The filename itself is first checked for a version number - but the number + is ignored if it doesn't contain any dots. + (prefix is checked to match with $pkgname, with a possible additional prefix + of lib or tcl) + Often (even usually) the parent or grandparent folder will be named as + per the package name with a proper version. If so we can return it, + otherwise return empty string. + The parent/grandparent matching will be done by looking for a case + insensitive match of the prefix to $pkgname. + " + @values -min 1 + libpath -help "Full path to shared library (.so,.dll etc)" + pkgname -help "" + }] + proc slibpath_guess_pkgversion {libpath pkgname} { + set root [file rootname [file tail $libpath]] + set namelen [string length $pkgname] + regexp {^(tcl(?:[0-9])+){0,1}(.*)} $root _match tclxx root ;#regexp will match anything - but only truncate leading tclXX.. + set testv "" + if {[string match -nocase $pkgname* $root]} { + set testv [string range $root $namelen end] + } elseif {[string match -nocase lib$pkgname* $root]} { + set testv [string range $root $namelen+3 end] + } + if {[string first . $testv] > 0} { + if {![catch [list package vcompare $testv $testv]]} { + #testv has an inner dot and is understood by tcl as a valid version number + return $testv + } + } + #no valid dotted version found directly on dll or so filename + set parent [file dirname $libpath] ;#parent folder is often some differentiator for platform or featureset (e.g win-x64) + set grandparent [file dirname $parent] + foreach path [list $parent $grandparent] { + set segment [file tail $path] + if {$segment eq "bin"} { + continue + } + set testv "" + if {[string match -nocase $pkgname* $segment]} { + set testv [string range $segment $namelen end] + } elseif {[string match -nocase critcl_$pkgname* $segment]} { + set testv [string range $segment $namelen+7 end] + } + #we don't look for dot in parent/grandparent version - a bare integer here after the will be taken to be the version + if {![catch [list package vcompare $testv $testv]]} { + return $testv + } + } + #review - sometimes path and lib are named only for major.minor but package provides major.minor.subversion + #using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion + return "" + } + +} + +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::packagepreference ::punk::packagepreference::system +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { + variable pkg punk::packagepreference + 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/path-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index 933ef860..1ddd56b7 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::path 0 0.1.0] #[copyright "2023"] #[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] +#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] #[require punk::path] #[description] #[keywords module path filesystem] @@ -45,8 +45,10 @@ #[list_begin itemized] package require Tcl 8.6- +package require punk::args #*** !doctools #[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] # #package require frobz # #*** !doctools @@ -63,11 +65,11 @@ package require Tcl 8.6- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::path::class { +#namespace eval punk::path::class { #*** !doctools #[subsection {Namespace punk::path::class}] #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { + #if {[info commands [namespace current]::interface_sample1] eq ""} { #*** !doctools #[list_begin enumerated] @@ -89,8 +91,8 @@ namespace eval punk::path::class { #*** !doctools #[list_end] [comment {--- end class enumeration ---}] - } -} + #} +#} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -102,21 +104,463 @@ namespace eval punk::path { #*** !doctools #[subsection {Namespace punk::path}] - #[para] Core API functions for punk::path + #[para] Core API functions for punk::path #[list_begin definitions] + # -- --- + #punk::path::normjoin + # - simplify . and .. segments as far as possible whilst respecting specific types of root. + # -- --- + #a form of file normalize that supports //xxx to be treated as server path names + #(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax) + #(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway) + # -- --- + #This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc + # + #TODO - option for caller to provide a -base below which we can't backtrack. + #This is preferable to setting policy here for example regarding forcing no trackback below //servername/share + #Our default is to allow trackback to: + # :// + # :/ + # //./ (dos device volume) + # //server (while normalizing //./UNC/server to same) + # / (ordinary unix root) + # ./../ - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks) + # + #The caller should do the file/vfs operations to determine this - not us. + # -- --- + #simplify path with respect to /./ & /../ elements - independent of platform + #NOTE: "anomalies" in standard tcl processing on windows: + #e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume) + #file normalize {//host/share} -> //host/share + #This is because //host is treated as volume-relative in cmd/powershell and Tcl quite reasonably follows suit. + #This prevents cwd and windows commandlines from pointing to the server (above the share) + #Explorer however does allow pointing to the //server level and seeing shares as if they are directory entries. + #we are more interested in supporting the explorer-like behaviour - as while volumerelative paths are also useful on windows - they are lesser known. + #REVIEW. + #To get back to some consistent cross platform behaviour - we will treat //something as a root/volume i.e we can't backtrack above it with ".." + #note too that file split on UNC paths doesn't give a clear indication of the root + # file split //./UNC/server/share/subpath -> //./UNC server share subpath + # file split //server/share/subpath -> //server/share subpath + #TODO - disallow all change of root or change from relative path to absolute result. + #e.g normjoin relpath/../d:/secret should not return d:/secret - but ./d:/secret + # ================ + #known issues: + #1) + # normjoin d://a//b//c -> d://a/b/c + # This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c + # Not considered a problem - just potentially surprising. + # To avoid it we would have to enumerate possible schemes. + # As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review. + # won't fix? + #2) + # normjoin https:///real.com/../fake.com -> https:///fake.com + # The extra slash means effectively our servername is empty - this is potentially confusing but probably the right thing to do here. + # It's a concern only if upstream treats the tripple slash in this case as valid and maps it to https:// - which would probably be bad anyway. + # won't fix (review) + #3) + #similarly + # normjoin //./UNC//server/share/subpath -> ///server/share/subpath (when 2 or more slashes directly after UNC) + # normjoin ///server/share -> ///server/share + #This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent + # possibly won't fix - review + #4) inconsistency + # we return normalized //server/share for //./UNC/server share + # but other dos device paths are maintained + # e.g //./c:/etc + # This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve. + # caller should + # #as with 'case' below - caller will need to run a post 'file normalize' + #5) we don't normalize case like file normalize does on windows platform. + # This is intentional. It could only be done with reference to underlying filesystem which we don't want here. + # + # ================ + # + #relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes) + # Tests - TODO + # normjoin /d:/..//vfs:/test -> /vfs:/test (good - not converted to //vfs:/test) + proc normjoin {args} { + set args [lmap a $args {string map "\\\\ /" $a}] + set path [plainjoin {*}$args] + switch -exact $path { + "" { + return "" + } + / - // { + #treated in unixlike manner - (but leading doubleslashes with subsequent data are server indication) + #// not considered a servername indicator - but /// (for consistency) is. (empty servername?) + return / + } + /// { + #if this is effectively //$emptyservername/ + #then for consistency we should trail //=3 + #todo - shortcircuit that here? + } + } + # /// + set doubleslash1_posn [string first // $path] + + # -- --- --- temp warning on windows only - no x-platform difference in result + #on windows //host is of type volumerelative + # whereas //host/share is of type absolute + if {"windows" eq $::tcl_platform(platform) && [file pathtype $path] eq "volumerelative"} { + #volumerelative probably only occurs on windows anyway + if {$doubleslash1_posn == 0} { + #e.g //something where no further slashes + #review - eventually get rid of this warning and require upstream to know the appropriate usecase + puts stderr "Warning - ambiguous path $path - treating as server path - not 'volumerelative'" + } else { + # /something/etc + # /mnt/c/stuff + #output will retain leading / as if on unix. + #on windows - the result would still be interpreted as volumerelative if the caller normalizes it + } + } + # -- --- --- + + set is_relpath 0 + + #set path [string map [list \\ /] $path] + set finalparts [list] + set is_nonunc_dosdevice 0 + if {[punk::winpath::is_dos_device_path $path]} { + #review + if {[string range $path 4 6] eq "UNC"} { + #convert to 'standard' //server/... path for processing + set path "/[string range $path 7 end]" ;# //server/... + } else { + #error "normjoin non-UNC dos device path '$path' not supported" + #first segment after //./ or //?/ represents the volume or drive. + #not applicable to unix - but unlikely to conflict with a genuine usecase there (review) + #we should pass through and stop navigation below //./vol + #!!! + #not anomaly in tcl (continues in tcl9) + #file exists //./c:/test -> 0 + #file exists //?/c:/test -> 1 + #file exists //./BootPartition/Windows -> 1 + #file exists //?/BootPartition/Windows -> 0 + set is_nonunc_dosdevice 1 + } + } + + if {$is_nonunc_dosdevice} { + #dosdevice prefix //./ or //?/ - preserve it (without trailing slash which will be put back in with join) + set prefix [string range $path 0 2] + set tail [string range $path 4 end] + set tailparts [split $tail /] + set parts [concat [list $prefix] $tailparts] + set rootindex 1 ;#disallow backtrack below //./ + } else { + #note use of ordinary ::split vs file split is deliberate. + if {$doubleslash1_posn == 0} { + #this is handled differently on different platforms as far as 'file split' is concerned. + #e.g for file split //sharehost/share/path/etc + #e.g on windows: -> //sharehost/share path + #e.g on freebsd: -> / sharehost share path etc + #however..also on windows: file split //sharehost -> / sharehost + #normalize by dropping leading slash before split - and then treating first 2 segments as a root + #set parts [file split [string range $path 1 end]] + set parts [split $path /] + #assert parts here has {} {} as first 2 entries + set rootindex 2 + #currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts) + #alternative handling for //zipfs:/path - don't go below mountpoint + #but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint + #review - more generally //:/path ? + #todo - make an option for zipfs and others to determine the 'base' + #if {"zipfs:" eq [lindex $parts 2]} { + # set rootindex 3 + #} + } else { + #path may or may not begin with a single slash here. + #treat same on unix and windows + set rootindex 0 + #set parts [file split $path] + set parts [::split $path /] + #e.g /a/b/c -> {} a b c + #or relative path a/b/c -> a b c + #or c:/a/b/c -> c: a b c + if {[string match *: [lindex $parts 0]]} { + if {[lindex $parts 1] eq ""} { + #scheme://x splits to scheme: {} x + set parts [concat [list [lindex $parts 0]/] [lrange $parts 2 end]] + #e.g {scheme:/ x} + set rootindex 1 ;#disallow below first element of scheme + } else { + set rootindex 0 + } + } elseif {[lindex $parts 0] ne ""} { + #relpath a/b/c + set parts [linsert $parts 0 .] + set rootindex 0 + #allow backtracking arbitrarily for leading .. entries - simplify where possible + #also need to stop possible conversion to absolute path + set is_relpath 1 + } + } + } + set baseparts [lrange $parts 0 $rootindex] ;#base below which we can't retreat via ".." + #puts stderr "-->baseparts:$baseparts" + #ensure that if our rootindex already spans a dotted segment (after the first one) we remove it + #must maintain initial . for relpaths to stop them converting to absolute via backtrack + # + set finalparts [list [lindex $baseparts 0]] + foreach b [lrange $baseparts 1 end] { + if {$b ni {. ..}} { + lappend finalparts $b + } + } + set baselen [expr {$rootindex + 1}] + if {$is_relpath} { + set i [expr {$rootindex+1}] + foreach p [lrange $parts $i end] { + switch -exact -- $p { + . - "" {} + .. { + switch -exact -- [lindex $finalparts end] { + . - .. { + lappend finalparts .. + } + default { + lpop finalparts + } + } + } + default { + lappend finalparts $p + } + } + incr i + } + } else { + foreach p [lrange $parts $rootindex+1 end] { + if {[llength $finalparts] <= $baselen} { + if {$p ni {. .. ""}} { + lappend finalparts $p + } + } else { + switch -exact -- $p { + . - "" {} + .. { + lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7 + } + default { + lappend finalparts $p + } + } + } + } + } + puts "==>finalparts: '$finalparts'" + # using join - {"" "" server share} -> //server/share and {a b} -> a/b + if {[llength $finalparts] == 1 && [lindex $finalparts 0] eq ""} { + #backtracking on unix-style path can end up with empty string as only member of finalparts + #e.g /x/.. + return / + } + set result [::join $finalparts /] + #normalize volumes and mountschemes to have trailing slash if no subpath + #e.g c: -> c:/ + #//zipfs: -> //zipfs:/ + if {[set lastchar [string index $result end]] eq ":"} { + if {$result eq "//zipfs:"} { + set result "//zipfs:/" + } else { + if {[string first / $result] < 0} { + set result $result/ + } + } + } elseif {[string match //* $result]} { + if {![punk::winpath::is_dos_device_path $result]} { + #server + set tail [string range $result 2 end] + set tailparts [split $tail /] + if {[llength $tailparts] <=1} { + #empty // or //servername + append result / + } + } + } elseif {[llength $finalparts] == 2} { + if {[string range [lindex $finalparts 0] end-1 end] eq ":/"} { + #e.g https://server/ -> finalparts {https:/ server} + #e.g https:/// -> finalparts {https:/ ""} + #scheme based path should always return trailing slash after server component - even if server component empty. + lappend finalparts "" ;#force trailing / + return [join $finalparts /] + } + } + return $result + } + + proc trim_final_slash {str} { + if {[string index $str end] eq "/"} { + return [string range $str 0 end-1] + } + return $str + } + + + #x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype' + # - no volumerelative + # - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms) + # - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC) + # - xxx:// as absolute (scheme) + # - xxx:/ or x:/ as absolute + # - x: xxx: -> as absolute (volume-basic or volume-extended) + + #note also on windows - legacy name for COM devices + # COM1 = COM1: + # //./COM1 ?? review + + proc pathtype {str} { + set str [string map "\\\\ /" $str] + if {[string index $str 0] eq "/"} { + #todo - look for //xxx:/ prefix (generalisation of //zipfs:/) as a 'volume' specifically {volume mount} ?? - review + # look for //server prefix as {absolute server} + # look for //./UNC/server or //?/UNC/server as {absolute server UNC} ? + # look for //./ as {absolute dosdevice} + return absolute + } + + #only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review + #e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is. + set firstslash [string first / $str] + if {$firstslash == -1} { + set firstsegment $str + } else { + set firstsegment [string range $str 0 $firstslash-1] + } + if {[set firstc [string first : $firstsegment]] > 0} { + set lhs_firstsegment [string range $firstsegment 0 $firstc-1] + set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc + if {$rhs_firstsegment eq ""} { + set rhs_entire_path [string range $str $firstc+1 end] + #assert lhs_firstsegment not empty since firstc > 0 + #count following / sequence + set i 0 + set slashes_after_firstsegment "" ;#run of slashes *directly* following first segment + while {$i < [string length $rhs_entire_path]} { + if {[string index $rhs_entire_path $i] eq "/"} { + append slashes_after_firstsegment / + } else { + break + } + incr i + } + switch -exact -- $slashes_after_firstsegment { + "" - / { + if {[string length $lhs_firstsegment] == 1} { + return {absolute volume basic} + } else { + return {absolute volume extended} + } + } + default { + #2 or more / + #this will return 'scheme' even for c:// - even though that may look like a windows volume - review + return {absolute scheme} + } + } + } + } + #assert first element of any return has been absolute or relative + return relative + } + + + proc plain {str} { + set str [string map "\\\\ /" $str] + set pathinfo [punk::path::pathtype $str] + if {[lindex $pathinfo 0] eq "relative" && ![string match ./* $str]} { + set str ./$str + } + if {[string index $str end] eq "/"} { + if {[string map {/ ""} $str] eq ""} { + #all slash segment + return $str + } else { + if {[lindex $pathinfo 1] ni {volume scheme}} { + return [string range $str 0 end-1] + } + } + } + return $str + } + #purely string based - no reference to filesystem knowledge + #unix-style forward slash only + proc plainjoin {args} { + set args [lmap a $args {string map "\\\\ /" $a}] + #if {[llength $args] == 1} { + # return [lindex $args 0] + #} + set out "" + foreach a $args { + if {![string length $out]} { + append out [plain $a] + } else { + set a [plain $a] + if {[string map {/ ""} $out] eq ""} { + set out [string range $out 0 end-1] + } + + if {[string map {/ ""} $a] eq ""} { + #all / segment + append out [string range $a 0 end-1] + } else { + if {[string length $a] > 2 && [string match "./*" $a]} { + set a [string range $a 2 end] + } + if {[string index $out end] eq "/"} { + append out $a + } else { + append out / $a + } + } + } + } + return $out + } + proc plainjoin1 {args} { + if {[llength $args] == 1} { + return [lindex $args 0] + } + set out [trim_final_slash [lindex $args 0]] + foreach a [lrange $args 1 end] { + set a [trim_final_slash $a] + append out / $a + } + return $out + } + + #intention? + #proc filepath_dotted_dirname {path} { + #} + + proc strip_prefixdepth {path prefix} { + if {$prefix eq ""} { + return [norm $path] + } + return [file join \ + {*}[lrange \ + [file split [norm $path]] \ + [llength [file split [norm $prefix]]] \ + end]] + } proc pathglob_as_re {pathglob} { #*** !doctools #[call [fun pathglob_as_re] [arg pathglob]] #[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure - #[para] ** matches any number of subdirectories. + #[para] ** matches any number of subdirectories. #[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) #[para] e.g /etc/**.txt will match any .txt files at any depth below /etc #[para] any segment that does not contain ** must match exactly one segment in the path - #[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc + #[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc #[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified. - #[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals + #[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals #todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? * @@ -128,9 +572,9 @@ namespace eval punk::path { } switch -- $seg { * {lappend pats {[^/]*}} - ** {lappend pats {.*}} + ** {lappend pats {.*}} default { - set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals + set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals #set seg [string map [list . {[.]}] $seg] set seg [string map {. [.]} $seg] if {[regexp {[*?]} $seg]} { @@ -170,14 +614,14 @@ namespace eval punk::path { } } } - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_nocase [dict get $opts -nocase] - set explicit_nocase 1 ;#default to disprove + set explicit_nocase 1 ;#default to disprove if {$opt_nocase eq "\uFFFF"} { set opt_nocase 0 set explicit_nocase 0 - } - # -- --- --- --- --- --- + } + # -- --- --- --- --- --- if {$opt_nocase} { return [regexp -nocase [pathglob_as_re $pathglob] $path] } else { @@ -200,47 +644,63 @@ namespace eval punk::path { return $ismatch } - #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ + punk::args::define { + @id -id ::punk::path::treefilenames + -directory -type directory -help\ + "folder in which to begin recursive scan for files." + -call-depth-internal -default 0 -type integer + -antiglob_paths -default {} -help\ + "list of path patterns to exclude + may include * and ** path segments e.g + /usr/** (exlude subfolders based at /usr but not + files within /usr itself) + **/_aside (exlude files where _aside is last segment) + **/_aside/* (exclude folders one below an _aside folder) + **/_aside/** (exclude all folders with _aside as a segment)" + -antiglob_files -default {} + @values -min 0 -max -1 -optional 1 -type string + tailglobs -default * -multiple 1 -help\ + "Patterns to match against filename portion (last segment) of each file path + within the directory tree being searched." + } + + #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) proc treefilenames {args} { #*** !doctools #[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]] #[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive #[para] options: - #[para] [opt -dir] + #[para] [opt -dir] #[para] defaults to [lb]pwd[rb] - base path for tree to search - #[para] [opt -antiglob_paths] + #[para] [opt -antiglob_paths] #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** #[para]no natsorting - so order is dependent on filesystem - set argd [punk::args::get_dict { - -directory -default "\uFFFF" - -call-depth-internal -default 0 -type integer - -antiglob_paths -default {} - *values -min 0 -max -1 -optional 1 -type string - tailglobs -multiple 1 - } $args] - lassign [dict values $argd] opts values - set tailglobs [dict values $values] + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + lassign [dict values $argd] leaders opts values received + set tailglobs [dict get $values tailglobs] # -- --- --- --- --- --- --- set opt_antiglob_paths [dict get $opts -antiglob_paths] + set opt_antiglob_files [dict get $opts -antiglob_files] set CALLDEPTH [dict get $opts -call-depth-internal] # -- --- --- --- --- --- --- - set opt_dir [dict get $opts -directory] - if {$opt_dir eq "\uFFFF"} { - set opt_dir [pwd] - } # -- --- --- --- --- --- --- set files [list] if {$CALLDEPTH == 0} { - if {![file isdirectory $opt_dir]} { - return [list] + #set opts [dict merge $opts [list -directory $opt_dir]] + if {![dict exists $received -directory]} { + set opt_dir [pwd] + } else { + set opt_dir [dict get $opts -directory] } - set opts [dict merge $opts [list -directory $opt_dir]] - if {![llength $tailglobs]} { - lappend tailglobs * + if {![file isdirectory $opt_dir]} { + return [list] } + } else { + #assume/require to exist in any recursive call + set opt_dir [dict get $opts -directory] } set skip 0 @@ -255,15 +715,43 @@ namespace eval punk::path { } #todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? - set dirfiles [lsort [glob -nocomplain -dir $opt_dir -type f {*}$tailglobs]] + if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} { + #we can get for example a permissions error + puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" + set dirfiles [list] + } else { + set retained [list] + if {[llength $opt_antiglob_files]} { + foreach m $matches { + set skip 0 + set ftail [file tail $m] + foreach anti $opt_antiglob_files { + if {[string match $anti $ftail]} { + set skip 1; break + } + } + if {!$skip} { + lappend retained $m + } + } + } else { + set retained $matches + } + set dirfiles [lsort $retained] + } + lappend files {*}$dirfiles - set dirdirs [glob -nocomplain -dir $opt_dir -type d *] + if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { + puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" + set dirdirs [list] + } + foreach dir $dirdirs { set skip 0 foreach anti $opt_antiglob_paths { if {[globmatchpath $anti $dir]} { set skip 1 - break + break } } if {$skip} { @@ -285,8 +773,8 @@ namespace eval punk::path { #[item] #[para] Arguments: # [list_begin arguments] - # [arg_def string reference] The path from which the relative path to location is determined. - # [arg_def string location] The location path which may be above or below the reference path + # [arg_def string reference] The path from which the relative path to location is determined. + # [arg_def string location] The location path which may be above or below the reference path # [list_end] #[item] #[para] Results: @@ -295,7 +783,7 @@ namespace eval punk::path { #[item] #[para] Notes: #[para] Both paths must be the same type - ie both absolute or both relative - #[para] Case sensitive. ie punk::path::relative /etc /etC + #[para] Case sensitive. ie punk::path::relative /etc /etC # will return ../etC #[para] On windows, the drive-letter component (only) is not case sensitive #[example_begin] @@ -316,7 +804,7 @@ namespace eval punk::path { #[example_begin] # P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below # - somewhere/below - # P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here + # P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here # - ../../lib/here #[example_end] #[list_end] @@ -333,7 +821,7 @@ namespace eval punk::path { #avoid normalizing if possible (file normalize *very* expensive on windows) set do_normalize 0 if {[file pathtype $reference] eq "relative"} { - #if reference is relative so is location + #if reference is relative so is location if {[regexp {[.]{2}} [list $reference $location]]} { set do_normalize 1 } @@ -399,7 +887,7 @@ namespace eval punk::path::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::path::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] @@ -419,17 +907,17 @@ namespace eval punk::path::lib { namespace eval punk::path::system { #*** !doctools #[subsection {Namespace punk::path::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 punk::path [namespace eval punk::path { variable pkg punk::path 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/punk/pipe-1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/pipe-1.0.tm new file mode 100644 index 00000000..0b5501ac --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/pipe-1.0.tm @@ -0,0 +1,853 @@ +# -*- 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::pipe 1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::pipe 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::pipe] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::pipe +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::pipe +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::pipe::class { + #*** !doctools + #[subsection {Namespace punk::pipe::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +tcl::namespace::eval punk::pipe { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace punk::pipe}] + #[para] Core API functions for punk::pipe + #[list_begin definitions] + + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + #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 should 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}] + } + + #debatable whether boolean_almost_equal is more surprising than 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. + #alternatively - 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)} + } + + #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)} + } + + + proc val [list [list v [lreplace x 0 0]]] {return $v} + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::pipe ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::pipe::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::pipe::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 + #} + + #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 [string trimleft $rhs] + #--- + #REVIEW! + #set rhs [regsub -all {\s{1,}} $rhs {}] ;#collapse all internal whitespace to a single token + #This stops us matching {/@**@x x} vs {/@**@x x} + #--- + + set rhs [tcl::string::map {: ? * [ ] \\ {"} " " } $rhs] + #review - we don't expect other command-incompatible chars such as colon? + return $rhs + } + + # 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 + } + } + + #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 + } + + + #note - empty data after trailing , is ignored. (comma as very last character) + # - fix by documentation only. double up trailing comma e.g ,, if desired to return pattern match plus all at end! + #todo - move to punk::pipe + 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 token "" + set end_var_posn -1 ;#first var_terminal encountered within each comma delimited section + set token_index 0 ;#index of terminal char within each token + set indq 0 + set inbraces 0 + set inesc 0 ;#whether last char was backslash (see also punk::escv) + set prevc "" + set char_index 0 + #if {[string index $varspecs end] eq ","} { + # set varspecs [string range $varspecs 0 end-1] + #} + set charcount 0 + foreach c [split $varspecs ""] { + incr charcount + if {$indq} { + if {$inesc} { + #puts stderr "inesc adding '$c'" + append token \\$c + } else { + if {$c eq {"}} { + set indq 0 + } else { + append token $c + } + } + } elseif {$inbraces} { + if {$inesc} { + append token \\$c + } else { + if {$c eq "\}"} { + incr inbraces -1 + if {$inbraces} { + append token $c + } + } elseif {$c eq "\{"} { + incr inbraces + if {$inbraces} { + append token $c + } + } 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 {"}} { + if {!$inesc} { + set indq 1 + } else { + append token $c + } + } elseif {$c eq "\{"} { + if {!$inesc} { + set inbraces 1 + } else { + append token $c + } + } elseif {$c eq ","} { + #set var $token + #set spec "" + #if {$end_var_posn > 0} { + # #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. + # #lassign [scan $token %${end_var_posn}s%s] var spec + # set var [string range $token 0 $end_var_posn-1] + # set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec + #} else { + # if {$end_var_posn == 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 end_var_posn -1 + } else { + append token $c + switch -exact -- $c { + ' { + set in_atom 1 + } + ( { + incr in_brackets + } + default { + if {$end_var_posn == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { + set end_var_posn $token_index + } + } + } + } + if {$c eq ","} { + set var $token + set spec "" + if {$end_var_posn > 0} { + #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. + #lassign [scan $token %${end_var_posn}s%s] var spec + set var [string range $token 0 $end_var_posn-1] + set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec + } else { + if {$end_var_posn == 0} { + set var "" + set spec $token + } + } + lappend varlist [list [string trim $var] $spec] + set token "" + set token_index -1 + set end_var_posn -1 + + } + } + + if {$charcount == [string length $varspecs]} { + if {!($indq || $inbraces || $in_atom || $in_brackets)} { + if {$c ne ","} { + set var $token + set spec "" + if {$end_var_posn > 0} { + #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. + #lassign [scan $token %${end_var_posn}s%s] var spec + set var [string range $token 0 $end_var_posn-1] + set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec + } else { + if {$end_var_posn == 0} { + set var "" + set spec $token + } + } + lappend varlist [list [string trim $var] $spec] + set token "" + set token_index -1 + set end_var_posn -1 + } + } + } + + 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 $end_var_posn] + # set var $token + # set spec "" + # if {$end_var_posn > 0} { + # #lassign [scan $token %${end_var_posn}s%s] var spec + # set var [string range $token 0 $end_var_posn-1] + # set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec + # } else { + # if {$end_var_posn == 0} { + # set var "" + # set spec $token + # } + # } + # #lappend varlist [list [string trim $var] [string trim $spec]] + # #spec needs to be able to match whitespace too + # lappend varlist [list [string trim $var] $spec] + #} + + return $varlist + } + + #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 [_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 _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] + } + + #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] + #JMN + #debug.punk.pipe.compile {proc $cmdname} + return $result + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::pipe::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::pipe::system { + #*** !doctools + #[subsection {Namespace punk::pipe::system}] + #[para] Internal functions that are not part of the API + + + +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::pipe { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::pipe" + @package -name "punk::pipe" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::pipe + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + return $about_topics + } + proc default_topics {} {return [list Description outline *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + punk pipeline features + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return $::punk::pipe::version + } + proc get_topic_Contributors {} { + set authors {{Julian Noble }} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_outline {} { + punk::args::lib::tstr -return string { + todo.. + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::pipe::about" + dict set overrides @cmd -name "punk::pipe::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::pipe + }] \n] + dict set overrides topic -choices [list {*}[punk::pipe::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::pipe::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::pipe::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::pipe::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + +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::pipe +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::pipe [tcl::namespace::eval punk::pipe { + variable pkg punk::pipe + variable version + set version 1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm new file mode 100644 index 00000000..bb769b48 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm @@ -0,0 +1,276 @@ +# -*- 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: shellspy/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::repl::codethread 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0] +#[copyright "2024"] +#[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] +#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] +#[require punk::repl::codethread] +#[keywords module repl] +#[description] +#[para] This is part of the infrastructure required for the punk::repl to operate + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::repl::codethread +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::repl::codethread +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::config +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::repl::codethread::class { + #*** !doctools + #[subsection {Namespace punk::repl::codethread::class}] + #[para] class definitions + #if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::repl::codethread { + tcl::namespace::export * + variable replthread + variable replthread_cond + variable running 0 + + variable output_stdout "" + variable output_stderr "" + + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::repl::codethread}] + #[para] Core API functions for punk::repl::codethread + #[list_begin definitions] + + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + variable run_command_cache + + proc is_running {} { + variable running + return $running + } + proc runscript {script} { + + #puts stderr "->runscript" + variable replthread_cond + #variable output_stdout + #set output_stdout "" + #variable output_stderr + #set output_stderr "" + #expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available + #if a thread::send is done from the commandline in a codethread - Tcl will + if {"code" ni [interp children] || ![info exists replthread_cond]} { + #in case someone tries calling from codethread directly - don't do anything or change any state + #(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) + #if called directly - the context will be within the first 'code' interp. + #inappropriate caller could add superfluous entries to shellfilter stack if function errors out + #inappropriate caller could affect tsv vars (if their interp allows that anyway) + puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread" + return + } + interp eval code [list set ::punk::repl::codethread::output_stdout ""] + interp eval code [list set ::punk::repl::codethread::output_stderr ""] + + set outstack [list] + set errstack [list] + upvar ::punk::config::running running_config + if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { + lappend outstack [interp eval code [list shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] + } + lappend outstack [interp eval code [list shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] + + if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { + lappend errstack [interp eval code [list shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] + # #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] + } + lappend errstack [interp eval code [list shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]] + + #an experiment + #set errhandle [shellfilter::stack::item_tophandle stderr] + #interp transfer "" $errhandle code + + set status [catch { + #shennanigans to keep compiled script around after call. + #otherwise when $script goes out of scope - internal rep of vars set in script changes. + #The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible. + interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone + interp eval code { + lappend ::codeinterp::run_command_cache $::codeinterp::clonescript + if {[llength $::codeinterp::run_command_cache] > 2000} { + set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache] + } + tcl::namespace::inscope $::punk::ns::ns_current $::codeinterp::clonescript + } + } result] + + + flush stdout + flush stderr + + #interp transfer code $errhandle "" + #flush $errhandle + set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] + set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] + #puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" + + set tid [thread::id] + tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] + tsv::set codethread_$tid status $status + tsv::set codethread_$tid result $result + tsv::set codethread_$tid errorcode $::errorCode + + + #only remove from shellfilter::stack the items we added to stack in this function + foreach s [lreverse $outstack] { + interp eval code [list shellfilter::stack::remove stdout $s] + } + foreach s [lreverse $errstack] { + interp eval code [list shellfilter::stack::remove stderr $s] + } + thread::cond notify $replthread_cond + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::repl::codethread::lib { + tcl::namespace::export * + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::repl::codethread::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::repl::codethread::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::repl::codethread::system { + #*** !doctools + #[subsection {Namespace punk::repl::codethread::system}] + #[para] Internal functions that are not part of the API + + + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread { + variable pkg punk::repl::codethread + 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/repl/codethread-0.1.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm new file mode 100644 index 00000000..a64eef0f --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm @@ -0,0 +1,321 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::repl::codethread 0.1.1 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::repl::codethread 0 0.1.1] +#[copyright "2024"] +#[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] +#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] +#[require punk::repl::codethread] +#[keywords module repl] +#[description] +#[para] This is part of the infrastructure required for the punk::repl to operate + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::repl::codethread +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::repl::codethread +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::config +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::repl::codethread::class { + + #*** !doctools + #[subsection {Namespace punk::repl::codethread::class}] + #[para] class definitions + + #if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { + + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::repl::codethread { + tcl::namespace::export * + variable replthread + variable replthread_cond + variable running 0 + + variable output_stdout "" + variable output_stderr "" + + #review/test + catch {package require punk::ns} + catch {package rquire punk::repl} + + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::repl::codethread}] + #[para] Core API functions for punk::repl::codethread + #[list_begin definitions] + + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + variable run_command_cache + + #Use interp exists instead.. + #if {[catch {interp children}]} { + # #8.6.10 doesn't have it.. when was it introduced? + #} else { + + #} + + proc is_running {} { + variable running + return $running + } + proc runscript {script} { + + #puts stderr "->runscript" + variable replthread_cond + #variable output_stdout "" + #variable output_stderr "" + + #expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available + #if a thread::send is done from the commandline in a codethread - Tcl will + if {![interp exists code] || ![info exists replthread_cond]} { + #in case someone tries calling from codethread directly - don't do anything or change any state + #(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) + #if called directly - the context will be within the first 'code' interp. + #inappropriate caller could add superfluous entries to shellfilter stack if function errors out + #inappropriate caller could affect tsv vars (if their interp allows that anyway) + puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread" + return + } + interp eval code [list set ::punk::repl::codethread::output_stdout ""] + interp eval code [list set ::punk::repl::codethread::output_stderr ""] + + set outstack [list] + set errstack [list] + upvar ::punk::config::running running_config + if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { + lappend outstack [interp eval code [list ::shellfilter::stack add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] + } + lappend outstack [interp eval code [list ::shellfilter::stack add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] + + if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { + lappend errstack [interp eval code [list ::shellfilter::stack add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] + # #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] + } + lappend errstack [interp eval code [list ::shellfilter::stack add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]] + + #an experiment + #set errhandle [shellfilter::stack::item_tophandle stderr] + #interp transfer "" $errhandle code + + set status [catch { + #shennanigans to keep compiled script around after call. + #otherwise when $script goes out of scope - internal rep of vars set in script changes. + #The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible. + + #interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone + interp eval code [list ::codeinterp::set_clone ::codeinterp::clonescript $script] ;#like objclone + + interp eval code {lappend ::codeinterp::run_command_cache $::codeinterp::clonescript} + + interp eval code { + #lappend ::codeinterp::run_command_cache $::codeinterp::clonescript + if {[llength $::codeinterp::run_command_cache] > 2000} { + set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache] + } + if {[string first ":::" $::punk::ns::ns_current] >= 0} { + #support for browsing 'odd' (inadvisable) namespaces + #don't use 'namespace exists' - will conflate ::test::x with ::test:::x + #if {$::punk::ns::ns_current in [namespace children [punk::ns::nsprefix $::punk::ns::ns_current]} { + #} + package require punk::ns + punk::ns::nseval_ifexists $::punk::ns::ns_current $::codeinterp::clonescript + } else { + if {![namespace exists $::punk::ns::ns_current]} { + namespace eval $::punk::ns::ns_current { + puts stderr "Created namespace: $::punk::ns::ns_current" + } + } + tcl::namespace::inscope $::punk::ns::ns_current $::codeinterp::clonescript + } + } + } result] + #temp test for subshell experimentation + #if {$status == 1} { + # puts stderr "--codethread::runscript error--------\n$::errorInfo" + #} + + + flush stdout + flush stderr + + #interp transfer code $errhandle "" + #flush $errhandle + #set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] + #set lastoutchar [string index [punk::ansi::ansistrip [interp eval code [list set ::punk::repl::codethread::output_stdout]]] end] + set lastoutpart [interp eval code {string range $::punk::repl::codethread::output_stdout end-100 end}] + #note we could be in a *large* ansi segment such as sixel data + #review - why do we need to ansistrip? + set lastoutchar [string index [punk::ansi::ansistrip $lastoutpart] end] + + #set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] + set lasterrpart [interp eval code {string range $::punk::repl::codethread::output_stderr end-100 end}] + set lasterrchar [string index [punk::ansi::ansistrip $lasterrpart] end] + #puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" + + set tid [thread::id] + tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] + tsv::set codethread_$tid status $status + tsv::set codethread_$tid result $result + tsv::set codethread_$tid errorcode $::errorCode + + + #only remove from shellfilter::stack the items we added to stack in this function + foreach s [lreverse $outstack] { + interp eval code [list ::shellfilter::stack remove stdout $s] + } + foreach s [lreverse $errstack] { + interp eval code [list ::shellfilter::stack remove stderr $s] + } + thread::cond notify $replthread_cond + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::repl::codethread::lib { + tcl::namespace::export * + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::repl::codethread::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::repl::codethread::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::repl::codethread::system { + #*** !doctools + #[subsection {Namespace punk::repl::codethread::system}] + #[para] Internal functions that are not part of the API + + + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread { + variable pkg punk::repl::codethread + variable version + set version 0.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index ee2384b4..a39fceaf 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -27,6 +27,11 @@ # # path/repo functions # + +#REVIEW punk::repo required early by punk boot script to find projectdir +#todo - split off basic find_project chain of functions to a smaller package and import as necessary here +#Then we can reduce early dependencies in punk boot + if {$::tcl_platform(platform) eq "windows"} { package require punk::winpath } else { @@ -34,16 +39,16 @@ if {$::tcl_platform(platform) eq "windows"} { } package require fileutil; #tcllib package require punk::path -package require punk::mix::base ;#uses core functions from punk::mix::base::lib namespace e.g cksum_path +package require punk::mix::base ;#uses core functions from punk::mix::base::lib namespace e.g cksum_path package require punk::mix::util ;#do_in_path # -- --- --- --- --- --- --- --- --- --- --- # For performance/efficiency reasons - use file functions on paths in preference to string operations -# e.g use file join +# e.g use file join # branch to avoid unnecessary calls to 'pwd' or 'file normalize' - which can be surprisingly expensive operations (as at tcl 8.7 2023) # pwd is only expensive if we treat it as a string instead of a list/path -# e.g +# e.g # > time {set x [pwd]} # 5 microsoeconds.. no problem # > time {set x [pwd]} @@ -57,17 +62,105 @@ package require punk::mix::util ;#do_in_path # -- --- --- --- --- --- --- --- --- --- --- namespace eval punk::repo { + variable PUNKARGS + variable PUNKARGS_aliases + + variable cached_command_paths + set cached_command_paths [dict create] + #anticipating possible removal of buggy caching from auto_execok + #mentioned in: https://core.tcl-lang.org/tcl/tktview/4dc35e0c0c + #this would leave the application to decide what it wants to cache in that regard. + proc Cached_auto_execok {name} { + return [auto_execok $name] + #variable cached_command_paths + #if {[dict exists $cached_command_paths $name]} { + # return [dict get $cached_command_paths $name] + #} + #set resolved [auto_execok $name] + #dict set cached_command_paths $name $resolved + #return $resolved + } + + proc get_fossil_usage {} { + set allcmds [runout -n fossil help -a] + set mainhelp [runout -n fossil help] + set maincommands [list] + foreach ln [split $mainhelp \n] { + set ln [string trim $ln] + if {$ln eq "" || [regexp {^[A-Z]+} $ln]} { + continue + } + lappend maincommands {*}$ln + } + set othercmds [punk::lib::ldiff $allcmds $maincommands] + + set result "@leaders -min 0\n" + + append result [tstr -return string { + subcommand -type string -choicecolumns 8 -choicegroups { + "frequently used commands" {${$maincommands}} + "" {${$othercmds}} + } + }] - #Todo - investigate proper way to install a client-side commit hook in the fossil project + return $result + } + + + #lappend PUNKARGS [list { + # @dynamic + # @id -id ::punk::repo::fossil_proxy + # @cmd -name fossil -help "fossil executable + # " + # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} + # } ""] + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::repo::fossil_proxy + @cmd -name fossil -help "fossil executable" + ${[punk::repo::get_fossil_usage]} + } ] + + + + #experiment + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::repo::fossil_proxy diff" + @cmd -name "fossil diff" -help "fossil diff" + @argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} + } ""] + lappend PUNKARGS [list { + #todo - remove this comment - testing dynamic directive + @dynamic + @id -id "::punk::repo::fossil_proxy add" + @cmd -name "fossil add" -help "fossil add + " + @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} + } ""] + #TODO + #lappend PUNKARGS [list { + # @dynamic + # @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs} + # @cmd -name "fossil add" -help "fossil add + # " + # @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} + # } ""] + lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} + lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} + + + #Todo - investigate proper way to install a client-side commit hook in the fossil project #Then we may still use this proxy to check the hook - but the required checks will occur when another shell used proc fossil_proxy {args} { set start_dir [pwd] - set fosroot [find_fossil $start_dir] + set fosroot [find_fossil $start_dir] set fossilcmd [lindex $args 0] set no_warning_commands [list "help" "dbstat" "grep" "diff" "xdiff" "cat" "version"] if {$fossilcmd ni $no_warning_commands } { - set repostate [find_repos $start_dir] + set repostate [find_repos $start_dir] } set no_prompt_commands [list "status" "info" {*}$no_warning_commands] @@ -76,7 +169,7 @@ namespace eval punk::repo { if {$fossilcmd ni $no_prompt_commands} { set fossilrepos [dict get $repostate fossil] if {[llength $fossilrepos] > 1} { - puts stdout [dict get $repostate warnings] + puts stdout [punk::ansi::a+ bold yellow][dict get $repostate warnings][punk::ansi::a] puts stdout "Operating on inner fossil repository: [lindex $fossilrepos 0]" puts stdout "Use FOSSIL instead of fossil to avoid this prompt and warning" set answer [askuser "Are you sure you want to perform the operation on this repo? Y/N"] @@ -123,24 +216,44 @@ namespace eval punk::repo { } } elseif {$fossilcmd in [list "info" "status"]} { #emit warning whether or not multiple fossil repos - puts stdout [dict get $repostate warnings] + puts stdout [punk::ansi::a+ bold yellow][dict get $repostate warnings][punk::ansi::a] } - set fossil_prog [auto_execok fossil] + set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog ne ""} { {*}$fossil_prog {*}$args } else { puts stderr "fossil command not found. Please install fossil" } } - interp alias "" fossil "" punk::repo::fossil_proxy + + + # --- + # Calling auto_execok on an external tool can be too slow to do during package load (e.g could be 150ms) #safe interps can't call auto_execok #At least let them load the package even though much of it may be unusable depending on the safe configuration - catch { - if {[auto_execok fossil] ne ""} { - interp alias "" FOSSIL "" {*}[auto_execok fossil] - } + #catch { + # if {[auto_execok fossil] ne ""} { + # interp alias "" FOSSIL "" {*}[auto_execok fossil] + # } + #} + # --- + # ---------- + # + + + #uppercase FOSSIL to bypass fossil as alias to fossil_proxy + #only necessary on unix? + #Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway + proc establish_FOSSIL {args} { + #review + if {![info exists ::auto_execs(FOSSIL)]} { + set ::auto_execs(FOSSIL) [auto_execok fossil] ;#may fail in safe interp + } + interp alias "" FOSSIL "" ;#delete establishment alias + FOSSIL {*}$args } + # ---------- proc askuser {question} { if {![catch {package require punk::lib}]} { @@ -184,7 +297,7 @@ namespace eval punk::repo { if {$path eq {}} { set path [pwd] } scanup $path is_fossil_root } - + proc find_git {{path {}}} { if {$path eq {}} { set path [pwd] } scanup $path is_git_root @@ -216,12 +329,31 @@ namespace eval punk::repo { } } } + lappend PUNKARGS [list { + @id -id "::punk::repo::find_project" + @cmd -name "punk::repo::find_project" -help\ + "Find and return the path for the root of + the project to which the supplied path belongs. + If the supplied path is empty, the current + working directory is used as the starting point + for the upwards search. + Returns nothing if there is no project at or + above the specified path." + @values -min 0 -max 1 + path -optional 1 -default "" -help\ + "May be an absolute or relative path. + The full specified path doesn't have + to exist. The code will walk upwards + along the segments of the supplied path + testing the result of 'is_project_root'." + }] proc find_project {{path {}}} { if {$path eq {}} { set path [pwd] } - scanup $path is_project_root + scanup $path is_project_root } - proc is_fossil_root {{path {}}} { + #detect if path is a fossil root - without consulting fossil databases + proc is_fossil_root2 {{path {}}} { if {$path eq {}} { set path [pwd] } #from kettle::path::is.fossil foreach control { @@ -234,20 +366,51 @@ namespace eval punk::repo { } return 0 } - + proc is_fossil_root {{path {}}} { + #much faster on windows than 'file exists' checks + if {$path eq {}} { set path [pwd] } + set control [list _FOSSIL_ .fslckout .fos] + #could be marked 'hidden' on windows + if {"windows" eq $::tcl_platform(platform)} { + set files [list {*}[glob -nocomplain -dir $path -types f -tail {*}$control] {*}[glob -nocomplain -dir $path -types {f hidden} -tail {*}$control]] + } else { + set files [glob -nocomplain -dir $path -types f -tail {*}$control] + } + expr {[llength $files] > 0} + } + #review - is a .git folder sufficient? #consider git rev-parse --git-dir ? proc is_git_root {{path {}}} { if {$path eq {}} { set path [pwd] } - set control [file join $path .git] - expr {[file exists $control] && [file isdirectory $control]} + #set control [file join $path .git] + #expr {[file exists $control] && [file isdirectory $control]} + if {"windows" eq $::tcl_platform(platform)} { + #:/ + #globbing for dotfiles in tcl is problematic across platforms - windows 'hidden' concept is independent + #we need to find .git whether hidden or not - so need 2 glob operations + #.git may or may not be set with windows 'hidden' attribute + set hiddengitdir [glob -nocomplain -dir $path -types {d hidden} -tail .git] + set nonhiddengitdir [glob -nocomplain -dir $path -types {d} -tail .git] ;#won't return hidden :/ + return [expr {[llength [list {*}$hiddengitdir {*}$nonhiddengitdir]] > 0}] + } else { + #:/ + #unix returns 'hidden' files even without the hidden type being specified - but only if the pattern explicitly matches + return [expr {[llength [glob -nocomplain -dir $path -types d -tail .git]] > 0}] ;#will return .git even though it is conventionally 'hidden' on unix :/ + } } proc is_repo_root {{path {}}} { if {$path eq {}} { set path [pwd] } - expr {[is_fossil_root $path] || [is_git_root $path]} + #expr {[is_fossil_root $path] || [is_git_root $path]} + expr {[is_git_root $path] || [is_fossil_root $path]} ;#is_git_root has less to check } - #require a minimum of src and src/modules|src/scriptapps|src/*/*.vfs - and that it's otherwise sensible - #we still run a high chance of picking up unintended candidates - but hopefully it's a reasonable balance. + + #after excluding undesirables; + #require a minimum of + # - (src and src/modules|src/scriptapps|src/vfs) + # - OR (src and punkproject.toml) + # - and that it's otherwise sensible + #we still run a chance of picking up unintended candidates - but hopefully it's a reasonable balance. proc is_candidate_root {{path {}}} { if {$path eq {}} { set path [pwd] } if {[file pathtype $path] eq "relative"} { @@ -266,24 +429,34 @@ namespace eval punk::repo { } #review - adjust to allow symlinks to folders? - foreach required { - src - } { - set req $path/$required - if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0} + #foreach required { + # src + #} { + # set req $path/$required + # if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0} + #} + set required [list src] + set found_required [glob -nocomplain -dir $path -types d -tails {*}$required] + if {[llength $found_required] < [llength $required]} { + return 0 } set src_subs [glob -nocomplain -dir $path/src -types d -tail *] #test for $path/src/lib is too common to be a useful indicator - if {"modules" in $src_subs || "scriptapps" in $src_subs} { + if {"modules" in $src_subs || "vfs" in $src_subs || "scriptapps" in $src_subs} { + #bare minimum 1 return 1 } - foreach sub $src_subs { - if {[string match *.vfs $sub]} { - return 1 - } + + #bare minimum2 + # - has src folder and (possibly empty?) punkproject.toml + if {[file exists $path/punkproject.toml]} { + return 1 } + #review - do we need to check if path is already within a project? + #can we have a nested project? Seems like asking for complexity and problems when considering possible effects for git/fossil + #todo - breadth first search with depth limit (say depth 3?) for *.tm or *.tcl as another positive qualifier for this dir to be a project-root #we probably don't want to deep search a src folder in case the user is accidentally in some other type of project's tree #such a src tree could be very large, so if we don't find tcl indicators near the root it's a good bet this isn't a candidate @@ -301,14 +474,22 @@ namespace eval punk::repo { } proc is_project_root {path} { - #review - find a reliable simple mechanism. Noting we have projects based on different templates. + #review - find a reliable simple mechanism. Noting we have projects based on different templates. #Should there be a specific required 'project' file of some sort? + #(punkproject.toml is a candidate) + #we don't want to solely rely on such a file being present + # - we may also have punkproject.toml in project_layout template folders for example #test for file/folder items indicating fossil or git workdir base - if {(![punk::repo::is_fossil_root $path]) && (![punk::repo::is_git_root $path])} { + #the 'dev' mechanism for creating projects automatically creates a fossil project + #(which can be ignored if the user wants to manage it with git - but should probably remain in place? review) + #however - we currently require that for it to be a 'project' there must be some version control. + #REVIEW. + # + if {![punk::repo::is_repo_root $path]} { return 0 } - #exclude some known places we wouldn't want to put a project + #exclude some known places we wouldn't want to put a project if {![is_candidate_root $path]} { return 0 } @@ -329,6 +510,11 @@ namespace eval punk::repo { #does a dual git/fossil repo make sense if both are committing?? # see: https://fossil-scm.org/home/doc/trunk/www/inout.wiki for bidirectional sync info proc workingdir_state {{abspath {}} args} { + + #we should try to minimize executable calls + #an extra git/fossil executable call required for tags + #git seems to require more executable calls + set defaults [list\ -repotypes [list fossil git]\ -repopaths ""\ @@ -337,13 +523,13 @@ namespace eval punk::repo { if {$abspath in [dict keys $defaults]} { set args [list $abspath {*}$args] set abspath "" - } + } set opts [dict merge $defaults $args] # -- --- --- --- --- --- --- --- --- --- --- --- set opt_repotypes [dict get $opts -repotypes] set opt_repopaths [dict get $opts -repopaths] if {"$opt_repopaths" ne ""} { - if {([llength $opt_repopaths] % 2 != 0) || ![dict exists $opt_repopaths closest]} { + if {([llength $opt_repopaths] % 2) || ![dict exists $opt_repopaths closest]} { error "workingdir_state error: -repopaths argument invalid. Expected a dict as retrieved using punk::repo::find_repos" } set repopaths $opt_repopaths @@ -370,7 +556,16 @@ namespace eval punk::repo { } if {$repodir eq ""} { - error "workingdir_state error: No repository found at or above path '$abspath'" + puts stderr "workingdir_state error: No repository found at or above path '$abspath'" + puts stderr "args: $args" + dict set resultdict revision {} + dict set resultdict revision_iso8601 {} + dict set resultdict paths {} + dict set resultdict ahead "" + dict set resultdict behind "" + dict set resultdict error {reason "no_repo_found"} + dict set resultdict repotype none + return $resultdict } set subpath [punk::path::relative $repodir $abspath] if {$subpath eq "."} { @@ -382,6 +577,8 @@ namespace eval punk::repo { set revision "" set revision_iso8601 "" set pathdict [dict create] + set branch "" + set tags "" if {![llength $repotypes_to_query]} { error "No tracking information available for project at $repodir with the chosen repotypes '$opt_repotypes'. Ensure project workingdir is a fossil (or git) checkout" @@ -394,7 +591,7 @@ namespace eval punk::repo { #For this reason we will store 'unchanged' records for both git and fossil so that the combined dict should represent all files in the revision if {$rt eq "fossil"} { dict set resultdict repotype fossil - set fossil_cmd [auto_execok fossil] + set fossil_cmd [Cached_auto_execok fossil] if {$fossil_cmd eq ""} { error "workingdir_state error: fossil executable doesn't seem to be available" } @@ -411,6 +608,38 @@ namespace eval punk::repo { } set revision_iso8601 "${revision_ymd}T${revision_hms}${revision_tz}" + #REVIEW! what are the semantic difference between tags in fossil v git? + #fossil has tagtypes such as propagated and singleton(onetime) + #if we get all tag info for the revision - we can get the current branch (branch=somename tag) at the same time + #by retrieving with --raw - we have to process some prefixes such as sym- but probably best not done here + #we will return all tags that apply to the current revision and let the caller decide the meanings + if {![catch {punk::mix::util::do_in_path $repodir [list exec {*}$fossil_cmd tag ls --raw $revision]} cmdresult]} { + set branchinfo [lindex [grep {branch=*} $cmdresult] 0] ;#first line match - should only be one + set branch [lindex [split $branchinfo =] 1] + set tags [list] + foreach ln [split $cmdresult \n] { + if {[string trim $ln] eq ""} { + continue + } + lappend tags [string trim $ln] + } + } + + #set tags_info [lindex [grep {tags:*} $fossilstate 0] ;#first line match - should only be one + #we get lines like: + #tags: trunk, main + #tags: trunk + #set rawtags [lrange $tags_info 1 end] ;#REVIEW + #set tags [list] + #foreach t $rawtags { + # lappend tags [string trimright $t ,] + #} + + + #if {![catch {punk::mix::util::do_in_path $repodir [list exec {*}$fossil_cmd branch current]} cmdresult]} { + # set branch $cmdresult ;#command result doesn't include newline etc + #} + dict set resultdict ahead "" dict set resultdict behind "" @@ -442,7 +671,7 @@ namespace eval punk::repo { set path [string trim [string range $ln [string length "MISSING "] end]] dict set pathdict $path "missing" } - "EXTRA * " { + "EXTRA *" { #fossil will explicitly list files in a new folder - as opposed to git which shows just the folder set path [string trim [string range $ln [string length "EXTRA "] end]] dict set pathdict $path "extra" @@ -461,9 +690,10 @@ namespace eval punk::repo { break } elseif {$rt eq "git"} { dict set resultdict repotype git - set git_cmd [auto_execok git] + set git_cmd [Cached_auto_execok git] # -uno = suppress ? lines. # -b = show ranch and tracking info + #our basic parsing/grepping assumes --porcelain=2 if {[catch {punk::mix::util::do_in_path $repodir [list exec {*}$git_cmd status --porcelain=2 -b -- $abspath]} gitstate]} { error "workingdir_state error: Unable to retrieve workingdir state using git. Errormsg: $gitstate" } @@ -473,6 +703,13 @@ namespace eval punk::repo { puts stderr "workingdir_state: git revision is (initial) - no file state to gather" break } + # line: # branch.head somebranchname + set branch [lindex [grep {# branch.head *} $gitstate] 0 2] + + if {![catch {punk::mix::util::do_in_path $repodir [list exec {*}$git_cmd describe --exact-match --tags]} cmdresult]} { + set tags $cmdresult ;#review - we have short tags vs longer.. e.g v0.1a vs v0.1a-184-g856fab4 - which is returned? Also how are multiple separated? + } + #often there will be no tag - so the common case is actually an error "fatal: not ag exactly matchs 'xxxx...'" # -- --- --- --- --- #could use %ci for ISO8601 data - see git-show manpage, but this will be in timezone of developer's machine - we need it in UTC for comparison to fossil outputs and other devs @@ -574,9 +811,11 @@ namespace eval punk::repo { puts stderr "workingdir_state - repotype $rt not supported" } } - dict set resultdict revision $revision - dict set resultdict revision_iso8601 $revision_iso8601 - dict set resultdict paths $pathdict + dict set resultdict branch $branch + dict set resultdict tags $tags + dict set resultdict revision $revision + dict set resultdict revision_iso8601 $revision_iso8601 + dict set resultdict paths $pathdict return $resultdict } proc workingdir_state_summary {repostate args} { @@ -584,8 +823,13 @@ namespace eval punk::repo { error "workingdir_state_summary error repostate doesn't appear to be a repostate dict. (use workingdir_state to create)" } package require overtype + + #the revision branch and tags are highly relevant to the file state - and workingdir_state currently retrieves them anyway + # - so we'll include them in the defaults + # - when we are including working dir state as part of other output - we could be duplicating branch/tag retrievals + # - todo - flags to stop duplicating effort ?? set defaults [dict create\ - -fields {ahead behind unchanged changed new missing extra}\ + -fields {revision branch tags ahead behind unchanged changed new missing extra}\ ] set opts [dict merge $defaults $args] # -- --- --- --- --- --- --- --- --- --- @@ -599,6 +843,8 @@ namespace eval punk::repo { subpath subpath\ revision revision\ revision_iso8601 revision_iso8601\ + branch branch\ + tags tags\ ahead ahead\ behind behind\ repotype repotype\ @@ -614,7 +860,7 @@ namespace eval punk::repo { } } if {$repotype eq "git"} { - dict set fieldnames extra "extra (files/folders)" + dict set fieldnames extra "extra (files/folders)" } set col1_fields [list] set col2_values [list] @@ -623,7 +869,7 @@ namespace eval punk::repo { lappend col2_values [dict get $summary_dict $f] } set title1 "" - set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_fields] {string length $v}]] + set widest1 [tcl::mathfunc::max {*}[lmap v [list $title1 {*}$col1_fields] {string length $v}]] set col1 [string repeat " " $widest1] set title2 "" set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2_values] {string length $v}]] @@ -636,14 +882,26 @@ namespace eval punk::repo { set result [string trimright $result \n] return $result } + + #todo - describe purpose and possibly rename proc workingdir_state_summary_dict {repostate} { if {![dict exists $repostate repotype] || ![dict exists $repostate paths]} { error "workingdir_state_summary_dict error repostate doesn't appear to be a repostate dict. (use workingdir_state to create)" } set filestates [dict values [dict get $repostate paths]] set path_count_fields [list unchanged changed new missing extra] - set state_fields [list ahead behind repodir subpath repotype revision revision_iso8601] + set state_fields [list ahead behind repodir subpath repotype revision revision_iso8601 branch tags] set dresult [dict create] + if {[dict exists $repostate error]} { + foreach f $state_fields { + dict set dresult $f "" + } + foreach f $path_count_fields { + dict set dresult $f "" + } + #todo? + return $dresult + } foreach f $state_fields { dict set dresult $f [dict get $repostate $f] } @@ -655,6 +913,7 @@ namespace eval punk::repo { #determine nature of possibly-nested repositories (of various types) at and above this path #Treat an untracked 'candidate' folder as a sort of repository proc find_repos {path} { + puts "find_repos '$path'" set start_dir $path #root is a 'project' if it it meets the candidate requrements and is under repo control @@ -669,6 +928,10 @@ namespace eval punk::repo { while {[string length [set fosroot [punk::repo::find_fossil $fos_search_from]]]} { lappend fossils_bottom_to_top $fosroot set fos_search_from [file dirname $fosroot] + if {$fos_search_from eq $fosroot} { + #root of filesystem is repo - unusual case - but without this we would never escape the while loop + break + } } dict set root_dict fossil $fossils_bottom_to_top @@ -677,6 +940,9 @@ namespace eval punk::repo { while {[string length [set gitroot [punk::repo::find_git $git_search_from]]]} { lappend gits_bottom_to_top $gitroot set git_search_from [file dirname $gitroot] + if {$git_search_from eq $gitroot} { + break + } } dict set root_dict git $gits_bottom_to_top @@ -685,6 +951,9 @@ namespace eval punk::repo { while {[string length [set candroot [punk::repo::find_candidate $cand_search_from]]]} { lappend candidates_bottom_to_top $candroot set cand_search_from [file dirname $candroot] + if {$cand_search_from eq $candroot} { + break + } } dict set root_dict candidate $candidates_bottom_to_top @@ -745,14 +1014,14 @@ namespace eval punk::repo { dict set root_dict closest [lindex $longest_first 0 1] ;#the *path* of the closest to start_dir dict set root_dict closest_types [lindex $longest_first 0 0] } - - set closest_fossil [lindex [dict get $root_dict fossil] 0] - set closest_fossil_len [llength [file split $closest_fossil]] - set closest_git [lindex [dict get $root_dict git] 0] - set closest_git_len [llength [file split $closest_git]] - set closest_candidate [lindex [dict get $root_dict candidate] 0] - set closest_candidate_len [llength [file split $closest_candidate]] + + set closest_fossil [lindex [dict get $root_dict fossil] 0] + set closest_fossil_len [llength [file split $closest_fossil]] + set closest_git [lindex [dict get $root_dict git] 0] + set closest_git_len [llength [file split $closest_git]] + set closest_candidate [lindex [dict get $root_dict candidate] 0] + set closest_candidate_len [llength [file split $closest_candidate]] if {$closest_candidate_len > $closest_fossil_len && $closest_candidate_len > $closest_git_len} { #only warn if this candidate is *within* a found repo root @@ -822,7 +1091,7 @@ namespace eval punk::repo { } proc fossil_get_repository_file {{path {}}} { if {$path eq {}} { set path [pwd] } - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set fossilinfo [::exec {*}$fossilcmd info] @@ -888,7 +1157,7 @@ namespace eval punk::repo { } if {$opt_ansi} { if {$opt_ansi_prompt eq "\uFFFF"} { - set ansiprompt [a+ green bold] + set ansiprompt [a+ green bold] } else { set ansiprompt [$opt_ansi_prompt] } @@ -907,7 +1176,7 @@ namespace eval punk::repo { set startdir $opt_parentfolder - set fossil_prog [auto_execok fossil] + set fossil_prog [Cached_auto_execok fossil] if {$fossil_prog eq ""} { puts stderr "Fossil not found. Please install fossil" return @@ -921,15 +1190,15 @@ namespace eval punk::repo { #Whilst it might detect a central repo folder in a non-standard location - it might also be annoying. #Todo - a separate environment variable for users to declare one or more locations where they would like to store project .fossil repositories? - set candidate_repo_folder_locations [list] + set candidate_repo_folder_locations [list] #- choose a sensible default based on where fossil put the global config dir - or on the existence of a .fossils folder in a 'standard' location #verify with user before creating a .fossils folder #always check env(FOSSIL_HOME) first - but this is designed to locate the global .fossil (or _fossil) file - .fossils repository folder doesn't have to be at the same location set usable_repo_folder_locations [list] - #If we find one, but it's not writable - add it to another list + #If we find one, but it's not writable - add it to another list set readonly_repo_folder_locations [list] - #Examine a few possible locations for .fossils folder set + #Examine a few possible locations for .fossils folder set #if containing folder is writable add to candidate list set testpaths [list] @@ -938,8 +1207,8 @@ namespace eval punk::repo { if {![catch {package require Tcl 8.7-}]} { set fossilhome [file normalize [file tildeexpand $fossilhome_raw]] } else { - #8.6 - set fossilhome [file normalize $fossilhome_raw] + #8.6 + set fossilhome [file normalize $fossilhome_raw] } lappend testpaths [file join $fossilhome .fossils] @@ -984,13 +1253,13 @@ namespace eval punk::repo { } } } - + set startdir_fossils [glob -nocomplain -dir $startdir -type f *.fossil] if {[llength $startdir_fossils]} { #user is already keeping .fossil files directly in curent dir - give them the option to easily keep doing this #(we don't add it if no .fossil files there already - as it is probably a niche requirement - or a sign the user hasn't thought about a better/central location) if {$startdir ni $usable_repo_folder_locations} { - lappend usable_repo_folder_locations $startdir + lappend usable_repo_folder_locations $startdir } } set choice_folders [list] @@ -1016,7 +1285,7 @@ namespace eval punk::repo { #no existing writable .fossil folders (and no existing .fossil files in startdir) #offer the (writable) candidate_repo_folder_locations foreach fld $candidate_repo_folder_locations { - lappend choice_folders [list index $i folder $fld folderexists 0 existingfossils "" conflict ""] + lappend choice_folders [list index $i folder $fld folderexists 0 existingfossils "" conflict ""] incr i } } @@ -1039,7 +1308,7 @@ namespace eval punk::repo { } set folderexists [dict get $option folderexists] if {$folderexists} { - set folderstatus "(existing folder)" + set folderstatus "(existing folder)" } else { set folderstatus "(CREATE folder for .fossil repository files)" } @@ -1047,7 +1316,7 @@ namespace eval punk::repo { } - #append the readonly_repo_folder_locations so that user is aware of them as it may affect their choice + #append the readonly_repo_folder_locations so that user is aware of them as it may affect their choice if {[llength $readonly_repo_folder_locations]} { append menu_message "--------------------------------------------------" \n foreach readonly $readonly_repo_folder_locations { @@ -1065,11 +1334,11 @@ namespace eval punk::repo { } else { if {[llength $choice_folders] || $opt_askpath} { puts stdout $menu_message - set max [llength $choice_folders] + set max [llength $choice_folders] if {$max == 1} { set rangemsg "the number 1" } else { - set rangemsg "a number from 1 to $max" + set rangemsg "a number from 1 to $max" } set menuprompt "${ansiprompt}Enter $rangemsg to select location. (or N to abort)${ansireset}" if {$opt_askpath} { @@ -1088,7 +1357,7 @@ namespace eval punk::repo { set answer [askuser "${ansiprompt}Do you want to create this folder? Type just the word mkdir to create it, or N for no${ansireset}"] if {[string equal mkdir [string tolower $answer]]} { if {[catch {file mkdir $repository_folder} errM]} { - puts stderr "Failed to create folder $repository_folder. Error $errM" + puts stderr "Failed to create folder $repository_folder. Error $errM" } } } else { @@ -1126,7 +1395,7 @@ namespace eval punk::repo { if {$index >= 0 && $index <= $max-1} { set repo_folder_choice [lindex $choice_folders $index] set repository_folder [dict get $repo_folder_choice folder] - puts stdout "Selected fossil location $repository_folder" + puts stdout "Selected fossil location $repository_folder" } else { puts stderr " No menu number matched - aborting." return @@ -1146,27 +1415,27 @@ namespace eval punk::repo { #------------------------------------ #limit to exec so full punk shell not required in scripts - proc git_revision {{path {}}} { + proc git_revision {{path ""}} { if {$path eq {}} { set path [pwd] } # ::kettle::path::revision.git do_in_path $path { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[Cached_auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } } return [string trim $v] } - proc git_remote {{path {{}}}} { + proc git_remote {{path ""}} { if {$path eq {}} { set path [pwd] } do_in_path $path { try { #git describe will error with 'No names found' if repo has no tags #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' + set v [::exec {*}[Cached_auto_execok git] remote -v] ;# consider 'git rev-parse --short HEAD' } on error {e o} { set v [lindex [split [dict get $o -errorinfo] \n] 0] } @@ -1176,8 +1445,8 @@ namespace eval punk::repo { proc fossil_revision {{path {}}} { if {$path eq {}} { set path [pwd] } - # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] + # ::kettle::path::revision.fossil + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set info [::exec {*}$fossilcmd info] @@ -1190,8 +1459,8 @@ namespace eval punk::repo { proc fossil_remote {{path {}}} { if {$path eq {}} { set path [pwd] } - # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] + # ::kettle::path::revision.fossil + set fossilcmd [Cached_auto_execok fossil] if {[llength $fossilcmd]} { do_in_path $path { set info [::exec {*}$fossilcmd remote ls] @@ -1204,11 +1473,11 @@ namespace eval punk::repo { proc fossil_get_configdb {{path {}}} { #fossil info will *usually* give us the necessary config-db info whether in a project folder or not but.. #a) It's expensive to shell-out and call it - #b) it won't give us a result if we are in a checkout folder which has had its repository moved + #b) it won't give us a result if we are in a checkout folder which has had its repository moved #this fairly extensive mechanism is designed to find it even if the environment has some weird goings-on regarding the filesystem/environment variables #This is unlikely to be necessary in most scenarios, where the location is related to the user's home directory - - #attempt 1 - environment vars and well-known locations + + #attempt 1 - environment vars and well-known locations #This is first because it's faster - but hopefully it's aligned with how fossil does it if {"windows" eq $::tcl_platform(platform)} { @@ -1225,7 +1494,7 @@ namespace eval punk::repo { if {[file exists $testfile]} { return $testfile } - } + } } else { foreach varname [list FOSSIL_HOME HOME ] { if {[info exists ::env($varname)]} { @@ -1244,20 +1513,20 @@ namespace eval punk::repo { if {[file exists $testfile]} { return $testfile } - } + } if {[info exists ::env(HOME)]} { set testfile [file join $::env(HOME) .config fossil.db] if {[file exists $testfile]} { return $testfile } - } + } } set original_cwd [pwd] #attempt2 - let fossil do it for us - hopefully based on current folder if {$path eq {}} {set path [pwd]} - set fossilcmd [auto_execok fossil] + set fossilcmd [Cached_auto_execok fossil] if {![llength $fossilcmd]} { set fossil_ok 0 } else { @@ -1293,13 +1562,13 @@ namespace eval punk::repo { cd $original_cwd } - #attempt 3 - getting desperate.. find other repos, determine their checkouts and run fossil in them to get a result + #attempt 3 - getting desperate.. find other repos, determine their checkouts and run fossil in them to get a result if {$fossil_ok} { #It should be extremely rare to need to resort to sqlite on the databases to find other potential repo paths #Conceivably only on some weird VFS or where some other filesystem strangeness is going on with our original path - or if the root volume itself is a broken fossil checkout #Examining the other repos gives us a chance at discovering some other filesystem/paths where things may not be broken if {![catch {package require sqlite3} errPackage]} { - #use fossil all ls and sqlite + #use fossil all ls and sqlite if {[catch {exec {*}$fossilcmd all ls} repolines]} { error "fossil_get_configdb cannot find repositories" } else { @@ -1344,7 +1613,7 @@ namespace eval punk::repo { error "fossil_get_configdb exhausted search options" } #------------------------------------ - + #temporarily cd to workpath to run script - return to correct path even on failure proc do_in_path {path script} { #from ::kettle::path::in @@ -1420,8 +1689,8 @@ namespace eval punk::repo { set platform $::tcl_platform(platform) } - #No - don't do this sort of path translation here - leave as option for specific utils only such as ./ - #Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work + #No - don't do this sort of path translation here - leave as option for specific utils only such as ./ + #Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work #We shouldn't break it totally just because accessing WSL/mingw paths is slightly more useful #if {$platform eq "windows"} { #return [file dirname [file normalize [punk::unixywindows::towinpath $path]/__]] @@ -1433,7 +1702,7 @@ namespace eval punk::repo { #This taken from kettle::path::strip #It doesn't compare the prefix contents presumably for speed when used in kettle::path::scan #renamed to better indicate its behaviour - + proc path_strip_prefixdepth {path prefix} { if {$prefix eq ""} { return [norm $path] @@ -1478,6 +1747,8 @@ namespace eval punk::repo { } } + interp alias "" fossil "" punk::repo::fossil_proxy + interp alias "" FOSSIL "" punk::repo::establish_FOSSIL interp alias {} is_fossil {} ::punk::repo::is_fossil interp alias {} is_fossil_root {} ::punk::repo::is_fossil_root @@ -1510,10 +1781,19 @@ namespace eval punk::repo::lib { } + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +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::repo +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::repo [namespace eval punk::repo { variable version - set version 0.1.1 + set version 0.1.1 }] return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/tdl-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/tdl-0.1.0.tm index 7f034c18..6b1480be 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/tdl-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/tdl-0.1.0.tm @@ -31,15 +31,19 @@ namespace eval punk::tdl { server -name trillion -os windows server -name vmhost1 -os FreeBSD { - guest -name bsd1 -vmmanager iocage + guest -name bsd1 -vmmanager bastille guest -name p1 -vmmanager bhyve } } - proc prettyparse {script} { - set i [interp create -safe] + proc prettyparse {script {safe 1}} { + if {$safe} { + set i [interp create -safe] + } else { + set i [interp create] + } try { # $i eval {unset {*}[info vars]} # foreach command [$i eval {info commands}] {$i hide $command} @@ -65,6 +69,7 @@ namespace eval punk::tdl { interp delete $i } } + proc prettyprint {data {level 0}} { set ind [string repeat " " $level] incr level diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm new file mode 100644 index 00000000..0b5bd298 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm @@ -0,0 +1,605 @@ +# -*- 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) CMcC 2010 +# +# @@ Meta Begin +# Application punk::trie 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::trie 0 0.1.0] +#[copyright "2010"] +#[titledesc {punk::trie API}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk::trie}] [comment {-- Description at end of page heading --}] +#[require punk::trie] +#[keywords module datastructure trie] +#[description] tcl trie implementation courtesy of CmcC (tcl wiki) +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::trie +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::trie +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# #tcl::namespace::eval punk::trie::class { +# #*** !doctools +# #[subsection {Namespace punk::trie::class}] +# #[para] class definitions +# #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { +# #*** !doctools +# #[list_begin enumerated] +# +# # oo::class create interface_sample1 { +# # #*** !doctools +# # #[enum] CLASS [class interface_sample1] +# # #[list_begin definitions] +# +# # method test {arg1} { +# # #*** !doctools +# # #[call class::interface_sample1 [method test] [arg arg1]] +# # #[para] test method +# # puts "test: $arg1" +# # } +# +# # #*** !doctools +# # #[list_end] [comment {-- end definitions interface_sample1}] +# # } +# +# #*** !doctools +# #[list_end] [comment {--- end class enumeration ---}] +# #} +# #} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::trie { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + #logger calls this in such a way that a straight uplevel can get us the vars/commands in messages substituted + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] punk::trie '[uplevel [list subst $txt]]'" + puts stderr $msg + } + package require logger + logger::initNamespace ::punk::trie + foreach lvl [logger::levels] { + interp alias {} ::punk::trie::Log_$lvl {} ::punk::trie::Dolog $lvl + log::logproc $lvl ::punk::trie::Log_$lvl + } + #namespace path ::punk::trie::log + + #*** !doctools + #[subsection {Namespace punk::trie}] + #[para] Core API functions for punk::trie + if {[tcl::info::commands [tcl::namespace::current]::trieclass] eq ""} { + #*** !doctools + #[list_begin enumerated] + + oo::class create [tcl::namespace::current]::trieclass { + #*** !doctools + #[enum] CLASS [class trieclass] + #[list_begin definitions] + + variable trie id + + method matches {t what} { + #*** !doctools + #[call class::trieclass [method matches] [arg t] [arg what]] + #[para] search for longest prefix, return matching prefix, element and suffix + + set matches {} + set wlen [string length $what] + foreach k [lsort -decreasing -dictionary [dict keys $t]] { + set klen [string length $k] + set match "" + for {set i 0} {$i < $klen + && $i < $wlen + && [string index $k $i] eq [string index $what $i] + } {incr i} { + append match [string index $k $i] + } + if {$match ne ""} { + lappend matches $match $k + } + } + #Debug.trie {matches: $what -> $matches} + ::punk::trie::log::debug {matches: $what -> $matches} + + if {[dict size $matches]} { + # find the longest matching prefix + set match [lindex [lsort -dictionary [dict keys $matches]] end] + set mel [dict get $matches $match] + set suffix [string range $what [string length $match] end] + + return [list $match $mel $suffix] + } else { + return {} ;# no matches + } + } + + # return next unique id if there's no proffered value + method id {value} { + if {$value} { + return $value + } else { + return [incr id] + } + } + + # insert an element with a given optional value into trie + # along path given by $args (no need to specify) + method insert {what {value 0} args} { + if {[llength $args]} { + set t [dict get $trie {*}$args] + } else { + set t $trie + } + + if {[dict exists $t $what]} { + #Debug.trie {$what is an exact match on path ($args $what)} + ::punk::trie::log::debug {$what is an exact match on path ($args $what)} + if {[catch {dict size [dict get $trie {*}$args $what]} size]} { + # the match is a leaf - we're done + } else { + # the match is a dict - we have to add a null + dict set trie {*}$args $what "" [my id $value] + } + + return ;# exact match - no change + } + + # search for longest prefix + set match [my matches $t $what] + + if {![llength $match]} { + ;# no matching prefix - new element + #Debug.trie {no matching prefix of '$what' in $t - add it on path ($args $what)} + ::punk::trie::log::debug {no matching prefix of '$what' in $t add it on path ($args $what)} + dict set trie {*}$args $what [my id $value] + return + } + + lassign $match match mel suffix ;# prefix, element of match, suffix + + if {$match ne $mel} { + # the matching element shares a prefix, but has a variant suffix + # it must be split + #Debug.trie {splitting '$mel' along '$match'} + ::punk::trie::log::debug {splitting '$mel' along '$match'} + + set melC [dict get $t $mel] + dict unset trie {*}$args $mel + dict set trie {*}$args $match [string range $mel [string length $match] end] $melC + } + + if {[catch {dict size [dict get $trie {*}$args $match]} size]} { + # the match is a leaf - must be split + if {$match eq $mel} { + # the matching element shares a prefix, but has a variant suffix + # it must be split + #Debug.trie {splitting '$mel' along '$match'} + ::punk::trie::log::debug {splitting '$mel' along '$match'} + set melC [dict get $t $mel] + dict unset trie {*}$args $mel + dict set trie {*}$args $match "" $melC + } + #Debug.trie {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'} + ::punk::trie::log::debug {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'} + set melid [dict get $t $mel] + dict set trie {*}$args $match $suffix [my id $value] + } else { + # it's a dict - keep searching + #Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} + ::punk::trie::log::debug {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} + my insert $suffix $value {*}$args $match + } + return + } + + # find a path matching an element $what + # if the element's not found, return the nearest path + method find_path {what args} { + if {[llength $args]} { + set t [dict get $trie {*}$args] + } else { + set t $trie + } + + if {[dict exists $t $what]} { + #Debug.trie {$what is an exact match on path ($args $what)} + return [list {*}$args $what] ;# exact match - no change + } + + # search for longest prefix + set match [my matches $t $what] + + if {![llength $match]} { + return $args + } + + lassign $match match mel suffix ;# prefix, element of match, suffix + + if {$match ne $mel} { + # the matching element shares a prefix, but has a variant suffix + # no match + return $args + } + + if {[catch {dict size [dict get $trie {*}$args $match]} size] || $size == 0} { + # got to a non-matching leaf - no match + return $args + } else { + # it's a dict - keep searching + #Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} + return [my find_path $suffix {*}$args $match] + } + } + + # given a trie, which may have been modified by deletion, + # optimize it by removing empty nodes and coalescing singleton nodes + method optimize {args} { + if {[llength $args]} { + set t [dict get $trie {*}$args] + } else { + set t $trie + } + + if {[catch {dict size $t} size]} { + #Debug.trie {optimize leaf '$t' along '$args'} + ::punk::trie::log::debug {optimize leaf '$t' along '$args'} + # leaf - leave it + } else { + switch -- $size { + 0 { + #Debug.trie {optimize empty dict ($t) along '$args'} + ::punk::trie::log::debug {optimize empty dict ($t) along '$args'} + if {[llength $args]} { + dict unset trie {*}$args + } + } + 1 { + #Debug.trie {optimize singleton dict ($t) along '$args'} + ::punk::trie::log::debug {optimize singleton dict ($t) along '$args'} + lassign $t k v + if {[llength $args]} { + dict unset trie {*}$args + } + append args $k + if {[llength $v]} { + dict set trie {*}$args $v + } + my optimize {*}$args + } + default { + #Debug.trie {optimize dict ($t) along '$args'} + ::punk::trie::log::debug {optimize dict ($t) along '$args'} + dict for {k v} $t { + my optimize {*}$args $k + } + } + } + } + } + + # delete element $what from trie + method delete {what} { + set path [my find_path $what] + if {[join $path ""] eq $what} { + #Debug.trie {del '$what' along ($path) was [dict get $trie {*}$path]} + if {[catch {dict size [dict get $trie {*}$path]} size]} { + # got to a matching leaf - delete it + dict unset trie {*}$path + set path [lrange $path 0 end-1] + } else { + dict unset trie {*}$path "" + } + + my optimize ;# remove empty and singleton elements + } else { + # nothing to delete, guess we're done + } + } + + # find the value of element $what in trie, + # error if not found + method find_or_error {what} { + set path [my find_path $what] + if {[join $path ""] eq $what} { + if {[catch {dict size [dict get $trie {*}$path]} size]} { + # got to a matching leaf - done + return [dict get $trie {*}$path] + } else { + #JMN - what could be an exact match for a path, but not be in the trie itself + if {[dict exists $trie {*}$path ""]} { + return [dict get $trie {*}$path ""] + } else { + ::punk::trie::log::debug {'$what' matches a path but is not a leaf} + error "'$what' not found" + } + } + } else { + error "'$what' not found" + } + } + #JMN - renamed original find to find_or_error + #prefer not to catch on result - but test for -1 + method find {what} { + set path [my find_path $what] + if {[join $path ""] eq $what} { + #presumably we use catch and dict size to avoid llength shimmering large inner dicts to list rep + if {[catch {dict size [dict get $trie {*}$path]} size]} { + # got to a matching leaf - done + return [dict get $trie {*}$path] + } else { + #JMN - what could be an exact match for a path, but not be in the trie itself + if {[dict exists $trie {*}$path ""]} { + return [dict get $trie {*}$path ""] + } else { + ::punk::trie::log::debug {'$what' matches a path but is not a leaf} + return -1 + } + } + } else { + return -1 + } + } + + # dump the trie as a string + method dump {} { + return $trie + } + + # return a string rep of the trie sorted in dict order + method order {{t {}}} { + if {![llength $t]} { + set t $trie + } elseif {[llength $t] == 1} { + return $t + } + set acc {} + + foreach key [lsort -dictionary [dict keys $t]] { + lappend acc $key [my order [dict get $t $key]] + } + return $acc + } + + # return the trie as a dict of names with values + method flatten {{t {}} {prefix ""}} { + if {![llength $t]} { + set t $trie + } elseif {[llength $t] == 1} { + return [list $prefix $t] + } + + set acc {} + dict for {key val} $t { + lappend acc {*}[my flatten $val $prefix$key] + } + return $acc + } + + #shortest possible string to identify an element in the trie using the same principle as tcl::prefix::match + #ie if a stored word is a prefix of any other words - it must be fully specified to identify itself. + #JMN - REVIEW - better algorithms? + #caller having retained all members can avoid flatten call + #by selecting a single 'which' known not to be in the trie (or empty string) - all idents can be returned. + #when all 'which' members are in the tree - scanning stops when they're all found + # - and a dict containing result and scanned keys is returned + # - result contains a dict with keys for each which member + # - scanned contains a dict of all words longer than our shortest which - (and a subset of words the same length) + method shortest_idents {which {allmembers {}}} { + set t $trie + if {![llength $allmembers]} { + set members [dict keys [my flatten]] + } else { + set members $allmembers + } + set len_members [lmap m $members {list [string length $m] $m}] + set longestfirst [lsort -index 0 -integer -decreasing $len_members] + set longestfirst [lmap v $longestfirst {lindex $v 1}] + set taken [dict create] + set scanned [dict create] + set result [dict create] ;#words in our which list - if found + foreach w $longestfirst { + set path [my find_path $w] + if {[dict exists $taken $w]} { + #whole word - no unique prefix + dict set scanned $w $w + if {$w in $which} { + #puts stderr "$w -> $w" + dict set result $w $w + if {[dict size $result] == [llength $which]} { + return [dict create result $result scanned $scanned] + } + } + continue + } + set acc "" + foreach p [lrange $path 0 end-1] { + dict set taken [append acc $p] 1 ;#no need to test first - just set even though may already be present + } + append acc [string index [lindex $path end] 0] + dict set scanned $w $acc ;#sorted by length - so no other can have this prefix - and no longer necessary + if {$w in $which} { + #puts stderr "$w -> $acc" + dict set result $w $acc + if {[dict size $result] == [llength $which]} { + return [dict create result $result scanned $scanned] + } + } + } + return [dict create result $result scanned $scanned] + } + + # overwrite the trie + method set {t} { + set trie $t + } + + constructor {args} { + set trie {} + set id 0 + foreach a $args { + my insert $a + } + } + + #*** !doctools + #[list_end] [comment {--- end definitions ---}] + } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + + set testlist [list blah x black blacken] + proc test1 {} { + #JMN + #test that find_or_error of a path that isn't stored as a value returns an appropriate error + #(used to report couldn't find dict key "") + set t [punk::trie::trieclass new blah x black blacken] + if {[catch {$t find_or_error bla} errM]} { + puts stderr "should be error indicating 'bla' not found" + puts stderr "err during $t find bla\n$errM" + } + return $t + } + + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + } + + + + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + + + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::trie::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::trie::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::trie::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::trie::system { + #*** !doctools + #[subsection {Namespace punk::trie::system}] + #[para] Internal functions that are not part of the API + + + +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::trie [tcl::namespace::eval punk::trie { + variable pkg punk::trie + 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/unixywindows-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/unixywindows-0.1.0.tm new file mode 100644 index 00000000..1d0a3957 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/unixywindows-0.1.0.tm @@ -0,0 +1,237 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::unixywindows 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +#for illegalname_test +package require punk::winpath + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::unixywindows { + #'cached' name to make obvious it could be out of date - and to distinguish from unixyroot arg + variable cachedunixyroot "" + + + #----------------- + #e.g something like c:/Users/geek/scoop/apps/msys2/current c:/msys2 + proc get_unixyroot {} { + variable cachedunixyroot + if {![string length $cachedunixyroot]} { + if {![catch { + set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. + set cachedunixyroot [punk::objclone $result] + file pathtype $cachedunixyroot; #this call causes the int-rep to be path + #set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display + } errM]} { + + } else { + puts stderr "Warning: Failed to determine base for unix-like paths - using default of c:/msys2" + file pathtype [set cachedunixyroot [punk::objclone "c:/msys2"]] + } + } + #will have been shimmered from string to 'path' internal rep by 'file pathtype' call + + #let's return a different copy as it's so easy to lose path-rep + set copy [punk::objclone $cachedunixyroot] + return $copy + } + proc refresh_unixyroot {} { + variable cachedunixyroot + set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. + set cachedunixyroot [punk::objclone $result] + file pathtype $cachedunixyroot; #this call causes the int-rep to be path + + set copy [punk::objclone $cachedunixyroot] + return $copy + } + proc set_unixyroot {windows_path} { + variable cachedunixyroot + file pathtype $windows_path + set cachedunixyroot [punk::objclone $windows_path] + #return the original - but probably int-rep will have shimmered to path even if started out as string + #- that's probably what we want. Caller can use as string or path without affecting cachedunixyroot + return $windows_path + } + + + proc windir {path} { + if {$path eq "~"} { + #as the tilde hasn't been normalized.. we can't assume we're running on the actual platform + return ~/.. + } + return [file dirname [towinpath $path]] + } + + #REVIEW high-coupling + proc cdwin {path} { + set path [towinpath $path] + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + if {[llength [info commands ::punk::console::titleset]]} { + ::punk::console::titleset $path + } + } + cd $path + } + proc cdwindir {path} { + set path [towinpath $path] + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + if {[llength [info commands ::punk::console::titleset]]} { + ::punk::console::titleset $path + } + } + cd [file dirname $path] + } + + #NOTE - this is an expensive operation - avoid where possible. + #review - is this intended to be useful/callable on non-windows platforms? + #it should in theory be useable from another platform that wants to create a path for use on windows. + #In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid) + #review zipfs:// other uri schemes? + proc towinpath {unixypath {unixyroot ""}} { + #NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) + #(Tcl is also somewhat broken as at 2023 as far as volume relative paths - process can get out of sync with tcl if cd to a vol relative path is used) + #This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. + #e.g there is potential confusion when there is a c folder on c: drive (c:/c) + #I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt + #whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. + #I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. + #It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists + #This makes it hard to use things like 'file normalize' - which also looks at things like current volume. + # + #Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep + #which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. + #The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common + # + #convert /c/etc to C:/etc + set re_slash_x_slash {^/([[:alpha:]]){1}/.*} + set re_slash_else {^/([[:alpha:]]*)(.*)} + set volumes [file volumes] + #exclude things like //zipfs:/ ?? + set driveletters [list] + foreach v $volumes { + if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { + lappend driveletters $letter + } + } + #puts stderr "->$driveletters" + + set path [punk::objclone $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument + set supplied_pathtype [file pathtype $path] ;#we don't care about the pathtype so much as the act of making this call shimmers to a path internal-rep + + #copy of var that we can treat as a string without affecting path rep + #Note that some but not all read operations will lose path rep e.g 'string length $x' will lose any path-rep $x had, (but 'string equal $x something' won't) + #Todo - make int-rep tests to check stability of these behaviours across Tcl versions! + set strcopy_path [punk::objclone $path] + + set str_newpath "" + + set have_pathobj 0 + + if {[regexp $re_slash_x_slash $strcopy_path _ letter]} { + #upper case appears to be windows canonical form + set str_newpath [string toupper $letter]:/[string range $strcopy_path 3 end] + } elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $strcopy_path] _ letter]} { + set str_newpath [string toupper $letter]:/[string range $strcopy_path 7 end] + } elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $strcopy_path] _ letter]} { + set str_newpath [string toupper $letter]:/ + } elseif {[regexp $re_slash_else $strcopy_path _ firstpart remainder]} { + #could be for example /c or /something/users + if {[string length $firstpart] == 1} { + set letter $firstpart + set str_newpath [string toupper $letter]:/ + } else { + #according to regex we have a single leading slash + set str_tail [string range $strcopy_path 1 end] + if {$unixyroot eq ""} { + set unixyroot [get_unixyroot] + } else { + file pathtype $unixyroot; #side-effect generates int-rep of type path ) + } + set pathobj [file join $unixyroot $str_tail] + file pathtype $pathobj + set have_pathobj 1 + } + } + + if {!$have_pathobj} { + if {$str_newpath eq ""} { + #dunno - pass through + set pathobj $path + } else { + set pathobj [punk::objclone $str_newpath] + file pathtype $pathobj + } + } + + + + #puts stderr "=> $path" + #things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder + # + #By now file normalize shouldn't do too many shannanigans related to cwd.. + #We want it to look at cwd for relative paths.. + #but we don't consider things like /c/Users to be relative even on windows where it would normally mean a volume-relative path e.g c:/c/Users if cwd happens to be somewhere on C: at the time. + #if {![file exists [file dirname $path]]} { + # set path [file normalize $path] + # #may still not exist.. that's ok. + #} + + + + #file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name + #2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes + if {[punk::winpath::illegalname_test $pathobj]} { + set pathobj [punk::winpath::illegalname_fix $pathobj] + } + + return $pathobj + } + + #---------------------------------------------- + #leave the unixywindows related aliases available on all platforms + #interp alias {} cdwin {} punk::unixywindows::cdwin + #interp alias {} cdwindir {} punk::unixywindoes::cdwindir + #interp alias {} towinpath {} punk::unixywindows::towinpath + #interp alias {} windir {} punk::unixywindows::windir + #---------------------------------------------- + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::unixywindows [namespace eval punk::unixywindows { + variable version + set version 0.1.0 +}] +return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/winpath-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/winpath-0.1.0.tm index b30133ba..6de745a8 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/winpath-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/winpath-0.1.0.tm @@ -30,7 +30,7 @@ namespace eval punk::winpath { #\\servername\share etc or \\?\UNC\servername\share etc. proc is_unc_path {path} { - set strcopy_path [punk::objclone $path] + set strcopy_path [punk::winpath::system::objclone $path] set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) if {[string first "//" $strcopy_path] == 0} { #check for "Dos device path" syntax @@ -77,7 +77,7 @@ namespace eval punk::winpath { #dos device path syntax allows windows api to acces extended-length paths and filenames with illegal path characters such as trailing dots or whitespace #(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax) proc is_dos_device_path {path} { - set strcopy_path [punk::objclone $path] + set strcopy_path [punk::winpath::system::objclone $path] set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) if {[string range $strcopy_path 0 3] in {//?/ //./}} { return 1 @@ -87,7 +87,7 @@ namespace eval punk::winpath { } proc strip_dos_device_prefix {path} { #it's unlikely to be valid to strip only //?/ from a //?/UNC path so check for it here and diver to strip that. - #(review.. or raise error because a //?/UNC path isn't *strictly* a UNC path? ) + #(review.. or raise error because a //?/UNC path isn't an ordinary dos device path? ) if {[is_unc_path $path]} { return [strip_unc_path_prefix $path] } @@ -98,18 +98,18 @@ namespace eval punk::winpath { } } proc strip_unc_path_prefix {path} { - if {[is_unc_path $path]} { - #//?/UNC/server/etc - set strcopy_path [punk::objclone $path] - set trimmedpath [string range $strcopy_path 7 end] - file pathtype $trimmedpath ;#shimmer it to path rep - return $trimmedpath - } elseif {is_unc_path_plain $path} { + if {[is_unc_path_plain $path]} { #plain unc //server - set strcopy_path [punk::objclone $path] + set strcopy_path [punk::winpath::system::objclone $path] set trimmedpath [string range $strcopy_path 2 end] file pathtype $trimmedpath return $trimmedpath + } elseif {is_unc_path $path} { + #//?/UNC/server/subpath or //./UNC/server/subpath + set strcopy_path [punk::winpath::system::objclone $path] + set trimmedpath [string range $strcopy_path 7 end] + file pathtype $trimmedpath ;#shimmer it to path rep + return $trimmedpath } else { return $path } @@ -153,7 +153,7 @@ namespace eval punk::winpath { error $err } - set strcopy_path [punk::objclone $path] + set strcopy_path [punk::winpath::system::objclone $path] #Note: path could still have leading double slash if it is a Dos device path: e.g. //?/c:/etc @@ -225,27 +225,124 @@ namespace eval punk::winpath { return 0 } - proc test_ntfs_tunneling {f1 f2 args} { - file mkdir $f1 - puts stderr "waiting 15secs..." - after 5000 {puts -nonewline stderr .} - after 5000 {puts -nonewline stderr .} - after 5000 {puts -nonewline stderr .} - after 500 {puts stderr \n} - file mkdir $f2 - puts stdout "$f1 [file stat $f1]" - puts stdout "$f2 [file stat $f2]" - file delete $f1 - puts stdout "renaming $f2 to $f1" - file rename $f2 $f1 - puts stdout "$f1 [file stat $f1]" - + proc shortname {path} { + set shortname "NA" + if {[catch { + set shortname [dict get [file attributes $path] -shortname] + } errM]} { + puts stderr "Failed to get shortname for '$path'" + } + return $shortname + } + proc test_ntfs_tunneling {prefix args} { + puts stderr "We are looking for whether any of the final $prefix files or dirs took over the ctime attribute of the original $prefix files or dirs" + puts stderr "We expect the ino values to get potentially reassigned depending on order of deletion/creation so matches are coincidental and not material" + puts stderr "The shortnames are similarly allocated as they come - so presumably match by coincidence" + puts stderr "However - if we record a file's shortname, then delete it. Recreating it by shortname within the tunneling timeframe will magically reassociate the longname" + puts stderr "use test_ntfs_tunneling2 to test shortname tunneling" + file mkdir $prefix-dir-rename + file mkdir $prefix-dir-recreate + set fd [open $prefix-file-recreate.txt w] + puts $fd "original for recreate" + close $fd + set fd [open $prefix-file-rename.txt w] + puts $fd "original for rename" + close $fd + puts stdout "ORIGINAL files/dirs" + puts stdout "$prefix-dir-rename [file stat $prefix-dir-rename] " + puts stdout "$prefix-dir-recreate [file stat $prefix-dir-recreate]" + puts stdout "$prefix-file-recreate.txt [file stat $prefix-file-recreate.txt] short:[shortname $prefix-file-recreate.txt]" + puts stdout "$prefix-file-rename.txt [file stat $prefix-file-rename.txt] short:[shortname $prefix-file-rename.txt]" + puts stderr "waiting 10secs (to have discernable ctime differences)" + after 5000 + puts -nonewline stderr . + after 5000 + puts -nonewline stderr . + after 500 + + #-- + #seems to make no diff whether created or copied - no tunneling seen with dirs + #file mkdir $prefix-dir-rename-temp + file copy $prefix-dir-rename $prefix-dir-rename-temp + #-- + puts stderr \n + puts stdout "$prefix-dir-rename-temp [file stat $prefix-dir-rename-temp] (temp to rename into place)" + puts stderr "deleting $prefix-dir-rename" + file delete $prefix-dir-rename + puts stdout "renaming $prefix-dir-rename-temp to $prefix-dir-rename" + file rename $prefix-dir-rename-temp $prefix-dir-rename + + puts stderr "deleting $prefix-dir-recreate" + file delete $prefix-dir-recreate + puts stdout "re-creating $prefix-dir-recreate" + file mkdir $prefix-dir-recreate + + puts stderr "deleting $prefix-file-recreate.txt" + file delete $prefix-file-recreate.txt + puts stderr "Recreating $prefix-file-recreate.txt" + set fd [open $prefix-file-recreate.txt w] + puts $fd "replacement" + close $fd + + puts stderr "copying $prefix-file-rename.txt to $prefix-file-rename-temp.txt" + file copy $prefix-file-rename.txt $prefix-file-rename-temp.txt + puts stdout "$prefix-file-rename-temp.txt [file stat $prefix-file-rename-temp.txt] short:[shortname $prefix-file-rename-temp.txt] (status of initial temp copy)" + puts stderr "modifying temp copy before deletion of original.. (append)" + set fd [open $prefix-file-rename-temp.txt a] + puts $fd "added to file" + close $fd + puts stdout "$prefix-file-rename-temp.txt [file stat $prefix-file-rename-temp.txt] short:[shortname $prefix-file-rename-temp.txt] (status of appended temp copy)" + puts stderr "deleting $prefix-file-rename.txt" + file delete $prefix-file-rename.txt + puts stderr "renaming temp file $prefix-file-rename-temp.txt to original $prefix-file-rename.txt" + file rename $prefix-file-rename-temp.txt $prefix-file-rename.txt + + puts stdout "Final files/dirs" + puts stdout "$prefix-dir-rename [file stat $prefix-dir-rename]" + puts stdout "$prefix-dir-recreate [file stat $prefix-dir-recreate]" + puts stdout "$prefix-file-recreate.txt [file stat $prefix-file-recreate.txt] short:[shortname $prefix-file-recreate.txt]" + puts stdout "$prefix-file-rename.txt [file stat $prefix-file-rename.txt] short:[shortname $prefix-file-rename.txt]" + } + proc test_ntfs_tunneling2 {prefix {waitms 15000}} { + #shortname -> longname tunneling + puts stderr "Tunneling only happens if we delete via shortname? review" + set f1 $prefix-longname-file1.txt + set f2 $prefix-longname-file2.txt + + set fd [open $f1 w];close $fd + set shortname1 [shortname $f1] + puts stderr "longname:$f1 has shortname:$shortname1" + set fd [open $f2 w];close $fd + set shortname2 [shortname $f2] + puts stderr "longname:$f2 has shortname:$shortname2" + + puts stderr "deleting $f1 via name $shortname1" + file delete $shortname1 + puts stdout "immediately recreating $shortname1 - should retain longname $f1 via tunneling" + set fd [open $shortname1 w];close $fd + set f1_exists [file exists $f1] + puts stdout "file exists $f1 = $f1_exists" + + puts stderr "deleting $f2 via name $shortname2" + file delete $shortname2 + puts stderr "Waiting [expr {$waitms / 1000}] seconds.. (standard tunneling timeframe is 15 seconds if registry hasn't been tweaked)" + after $waitms + puts stdout "recreating $shortname2 after wait of $waitms ms - longname lost?" + set fd [open $shortname2 w];close $fd + set f2_exists [file exists $f2] + puts stdout "file exists $f2 = $f2_exists" + + puts stdout -done- } - } - +namespace eval punk::winpath::system { + #get a copy of the item without affecting internal rep + proc objclone {obj} { + append obj2 $obj {} + } +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/zip-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/zip-0.1.0.tm new file mode 100644 index 00000000..44af7472 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/zip-0.1.0.tm @@ -0,0 +1,761 @@ +# -*- 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: 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) 2024 JMN +# (C) 2009 Path Thoyts +# +# @@ Meta Begin +# Application punk::zip 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::zip 0 0.1.0] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::zip] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::zip +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::zip +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::args}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::zip::class { + #*** !doctools + #[subsection {Namespace punk::zip::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::zip { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::zip}] + #[para] Core API functions for punk::zip + #[list_begin definitions] + + proc Path_a_atorbelow_b {path_a path_b} { + return [expr {[StripPath $path_b $path_a] ne $path_a}] + } + proc Path_a_at_b {path_a path_b} { + return [expr {[StripPath $path_a $path_b] eq "." }] + } + + proc Path_strip_alreadynormalized_prefixdepth {path prefix} { + if {$prefix eq ""} { + return $path + } + set pathparts [file split $path] + set prefixparts [file split $prefix] + if {[llength $prefixparts] >= [llength $pathparts]} { + return "" + } + return [file join \ + {*}[lrange \ + $pathparts \ + [llength $prefixparts] \ + end]] + } + + #StripPath - borrowed from tcllib fileutil + # ::fileutil::stripPath -- + # + # If the specified path references/is a path in prefix (or prefix itself) it + # is made relative to prefix. Otherwise it is left unchanged. + # In the case of it being prefix itself the result is the string '.'. + # + # Arguments: + # prefix prefix to strip from the path. + # path path to modify + # + # Results: + # path The (possibly) modified path. + + if {[string equal $::tcl_platform(platform) windows]} { + # Windows. While paths are stored with letter-case preserved al + # comparisons have to be done case-insensitive. For reference see + # SF Tcllib Bug 2499641. + + proc StripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal -nocase $prefix $npath]} { + return "." + } + + if {[string match -nocase "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } + } else { + proc StripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal $prefix $npath]} { + return "." + } + + if {[string match "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } + } + + proc Timet_to_dos {time_t} { + #*** !doctools + #[call [fun Timet_to_dos] [arg time_t]] + #[para] convert a unix timestamp into a DOS timestamp for ZIP times. + #[example { + # DOS timestamps are 32 bits split into bit regions as follows: + # 24 16 8 0 + # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ + # |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| + # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ + #}] + set s [clock format $time_t -format {%Y %m %e %k %M %S}] + scan $s {%d %d %d %d %d %d} year month day hour min sec + expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) + | ($hour << 11) | ($min << 5) | ($sec >> 1)} + } + + proc walk {args} { + #*** !doctools + #[call [fun walk] [arg ?options?] [arg base]] + #[para] Walk a directory tree rooted at base + #[para] the -excludes list can be a set of glob expressions to match against files and avoid + #[para] e.g + #[example { + # punk::zip::walk -exclude {CVS/* *~.#*} library + #}] + + set argd [punk::args::get_dict { + *proc -name punk::zip::walk + -excludes -default "" -help "list of glob expressions to match against files and exclude" + -subpath -default "" + *values -min 1 -max -1 + base + fileglobs -default {*} -multiple 1 + } $args] + set base [dict get $argd values base] + set fileglobs [dict get $argd values fileglobs] + set subpath [dict get $argd opts -subpath] + set excludes [dict get $argd opts -excludes] + + + set imatch [list] + foreach fg $fileglobs { + lappend imatch [file join $subpath $fg] + } + + set result {} + #set imatch [file join $subpath $match] + set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] + foreach file $files { + set excluded 0 + foreach glob $excludes { + if {[string match $glob $file]} { + set excluded 1 + break + } + } + if {!$excluded} {lappend result $file} + } + foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { + set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] + if {[llength $subdir_entries]>0} { + #NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" + #This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash + #Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. + set result [list {*}$result "$dir/" {*}$subdir_entries] + } + } + return $result + } + + + proc extract_zip_prefix {infile outfile} { + set inzip [open $infile r] + fconfigure $inzip -encoding iso8859-1 -translation binary + if {[file exists $outfile]} { + error "outfile $outfile already exists - please remove first" + } + chan seek $inzip 0 end + set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent + chan seek $inzip 0 start + #only scan last 64k - cover max signature size?? review + if {$insize < 65559} { + set tailsearch_start 0 + } else { + set tailsearch_start [expr {$insize - 65559}] + } + chan seek $inzip $tailsearch_start start + set scan [read $inzip] + #EOCD - End Of Central Directory record + set start_of_end [string last "\x50\x4b\x05\x06" $scan] + puts stdout "==>start_of_end: $start_of_end" + + if {$start_of_end == -1} { + #no zip cdr - consider entire file to be the zip prefix + set baseoffset $insize + } else { + set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] + chan seek $inzip $filerelative_eocd_posn + set cdir_record_plus [read $inzip] ;#can have trailing data + binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + #rule out a false positive from within a nonzip (e.g plain exe) + #There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. + #It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway + #we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros + #todo - just search for Pk\5\6\0\0\0\0 in the first place? //review + if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { + #review - should keep searching? + #for now we assume not a zip + set baseoffset $insize + } else { + #use the central dir size to jump back tko start of central dir + #determine if diroffset is file or archive relative + + set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] + puts stdout "---> [read $inzip 4]" + if {$filerelative_cdir_start > $eocd(diroffset)} { + #easy case - 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier + #though we are assuming zip offsets are not corrupted + set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] + } else { + #hard case - either no prefix - or offsets have been adjusted to be file relative. + #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers + #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? + #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete + + #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) + #we can't assume they're ordered in any particular way - so we in theory have to look at them all. + set baseoffset "unknown" + chan seek $inzip $filerelative_cdir_start start + #binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + # eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + #load the whole central dir into cdir + + #todo! loop through all cdr file headers - find highest offset? + #tclZipfs.c just looks at first file header in Central Directory + #looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW + + set cdirdata [read $inzip $eocd(dirsize)] + binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ + cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ + cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) + + #since we're in this branch - we assume cdir(relativeoffset) is from the start of the file + chan seek $inzip $cdir(relativeoffset) + #let's at least check that we landed on a local file header.. + set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field + binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ + lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) + #dec2hex 67324752 = 4034B50 = PK\3\4 + puts stdout "1st local file header sig: $lfh(signature)" + if {$lfh(signature) == 67324752} { + #looks like a local file header + #use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) + set baseoffset $cdir(relativeoffset) + } + } + puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" + } + } + puts stdout "baseoffset: $baseoffset" + #expect CDFH PK\1\2 + #above the CDFH - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) + #above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script + + if {![string is integer -strict $baseoffset]} { + error "unable to determine zip baseoffset of file $infile" + } + + if {$baseoffset < $insize} { + set out [open $outfile w] + fconfigure $out -encoding iso8859-1 -translation binary + chan seek $inzip 0 start + chan copy $inzip $out -size $baseoffset + close $out + close $inzip + } else { + close $inzip + file copy $infile $outfile + } + } + + + + # Mkzipfile -- + # + # FIX ME: should handle the current offset for non-seekable channels + # + proc Mkzipfile {zipchan base path {comment ""}} { + #*** !doctools + #[call [fun Mkzipfile] [arg zipchan] [arg base] [arg path] [arg ?comment?]] + #[para] Add a single file to a zip archive + #[para] The zipchan channel should already be open and binary. + #[para] You can provide a -comment for the file. + #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. + + set fullpath [file join $base $path] + set mtime [Timet_to_dos [file mtime $fullpath]] + set utfpath [encoding convertto utf-8 $path] + set utfcomment [encoding convertto utf-8 $comment] + set flags [expr {(1<<11)}] ;# utf-8 comment and path + set method 0 ;# store 0, deflate 8 + set attr 0 ;# text or binary (default binary) + set version 20 ;# minumum version req'd to extract + set extra "" + set crc 0 + set size 0 + set csize 0 + set data "" + set seekable [expr {[tell $zipchan] != -1}] + if {[file isdirectory $fullpath]} { + set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) + #set attrex 0x40000010 + } elseif {[file executable $fullpath]} { + set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) + } else { + set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) + if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { + set attr 1 ;# text + } + } + + if {[file isfile $fullpath]} { + set size [file size $fullpath] + if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} + } + + + set offset [tell $zipchan] + set local [binary format a4sssiiiiss PK\03\04 \ + $version $flags $method $mtime $crc $csize $size \ + [string length $utfpath] [string length $extra]] + append local $utfpath $extra + puts -nonewline $zipchan $local + + if {[file isfile $fullpath]} { + # If the file is under 2MB then zip in one chunk, otherwize we use + # streaming to avoid requiring excess memory. This helps to prevent + # storing re-compressed data that may be larger than the source when + # handling PNG or JPEG or nested ZIP files. + if {$size < 0x00200000} { + set fin [open $fullpath rb] + set data [read $fin] + set crc [zlib crc32 $data] + set cdata [zlib deflate $data] + if {[string length $cdata] < $size} { + set method 8 + set data $cdata + } + close $fin + set csize [string length $data] + puts -nonewline $zipchan $data + } else { + set method 8 + set fin [open $fullpath rb] + set zlib [zlib stream deflate] + while {![eof $fin]} { + set data [read $fin 4096] + set crc [zlib crc32 $data $crc] + $zlib put $data + if {[string length [set zdata [$zlib get]]]} { + incr csize [string length $zdata] + puts -nonewline $zipchan $zdata + } + } + close $fin + $zlib finalize + set zdata [$zlib get] + incr csize [string length $zdata] + puts -nonewline $zipchan $zdata + $zlib close + } + + if {$seekable} { + # update the header if the output is seekable + set local [binary format a4sssiiii PK\03\04 \ + $version $flags $method $mtime $crc $csize $size] + set current [tell $zipchan] + seek $zipchan $offset + puts -nonewline $zipchan $local + seek $zipchan $current + } else { + # Write a data descriptor record + set ddesc [binary format a4iii PK\7\8 $crc $csize $size] + puts -nonewline $zipchan $ddesc + } + } + + #PK\x01\x02 Cdentral directory file header + #set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 + set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) + + set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ + $version $flags $method $mtime $crc $csize $size \ + [string length $utfpath] [string length $extra]\ + [string length $utfcomment] 0 $attr $attrex $offset] + append hdr $utfpath $extra $utfcomment + return $hdr + } + + #### REVIEW!!! + #JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') + # we probably want offsets to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) + #### + + # zip::mkzip -- + # + # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt + # + proc mkzip {args} { + #*** !doctools + #[call [fun mkzip] [arg ?options?] [arg filename]] + #[para] Create a zip archive in 'filename' + #[para] If a file already exists, an error will be raised. + set argd [punk::args::get_dict { + *proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" + *opts + -return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal + " + -zipkit -default 0 -type none -help "" + -runtime -default "" -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + " + -comment -default "" -help "An optional comment for the archive" + -directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" + -base -default "" -help "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + *values -min 1 -max -1 + filename -default "" -help "name of zipfile to create" + globs -default {*} -multiple 1 -help "list of glob patterns to match. + Only directories with matching files will be included in the archive" + } $args] + + set filename [dict get $argd values filename] + if {$filename eq ""} { + error "mkzip filename cannot be empty string" + } + if {[regexp {[?*]} $filename]} { + #catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name + error "mkzip filename should not contain glob characters ? *" + } + if {[file exists $filename]} { + error "mkzip filename:$filename already exists" + } + dict for {k v} [dict get $argd opts] { + switch -- $k { + -comment { + dict set argd opts $k [encoding convertto utf-8 $v] + } + -directory - -base { + dict set argd opts $k [file normalize $v] + } + } + } + + array set opts [dict get $argd opts] + + + if {$opts(-directory) ne ""} { + if {$opts(-base) ne ""} { + #-base and -directory have been normalized already + if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { + error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)" + } + set base $opts(-base) + set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] + } else { + set base $opts(-directory) + set relpath "" + } + set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] + + set norm_filename [file normalize $filename] + set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) + if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { + #check that we aren't adding the zipfile to itself + #REVIEW - now that we open zipfile after scanning - this isn't really a concern! + #keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) + #In the case of -force - we may want to delay replacement of original until scan is done? + + #try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each + #1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths + set self_globs_match 0 + foreach g [dict get $argd values globs] { + if {[string match $g [file tail $filename]]} { + set self_globs_match 1 + break + } + } + if {$self_globs_match} { + #still dangerous + set self_excluded 0 + foreach e $opts(-exclude) { + if {[string match $e [file tail $filename]]} { + set self_excluded 1 + break + } + } + if {!$self_excluded} { + #still dangerous - likely to be in resultset - check each path + #puts stderr "zip file $filename is below directory $opts(-directory)" + set self_is_matched 0 + set i 0 + foreach p $paths { + set norm_p [file normalize [file join $opts(-directory) $p]] + if {[Path_a_at_b $norm_filename $norm_p]} { + set self_is_matched 1 + break + } + incr i + } + if {$self_is_matched} { + puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" + set paths [lremove $paths $i] + } + } + } + } + } else { + set paths [list] + set dir [pwd] + if {$opts(-base) ne ""} { + if {![Path_a_atorbelow_b $dir $opts(-base)]} { + error "punk::zip::mkzip -base $opts(-base) must be above current directory" + } + set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] + } else { + set relpath "" + } + set base $opts(-base) + + set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] + foreach m $matches { + if {$m eq $filename} { + #puts stderr "--> excluding $filename" + continue + } + set isok 1 + foreach e [concat $opts(-exclude) $filename] { + if {[string match $e $m]} { + set isok 0 + break + } + } + if {$isok} { + lappend paths [file join $relpath $m] + } + } + } + + if {![llength $paths]} { + return "" + } + + set zf [open $filename wb] + if {$opts(-runtime) ne ""} { + set rt [open $opts(-runtime) rb] + fcopy $rt $zf + close $rt + } elseif {$opts(-zipkit)} { + #TODO - update to zipfs ? + #see modpod + set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" + append zkd "package require vfs::zip\n" + append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" + append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" + append zkd " source \[file join \[info script\] main.tcl\]\n" + append zkd "}\n" + append zkd \x1A + puts -nonewline $zf $zkd + } + + #todo - subtract this from the endrec offset.. and any ... ? + set dataStartOffset [tell $zf] ;#the overall file offset of the start of data section //JMN 2024 + + set count 0 + set cd "" + + set members [list] + foreach path $paths { + #puts $path + lappend members $path + append cd [Mkzipfile $zf $base $path] ;#path already includes relpath + incr count + } + set cdoffset [tell $zf] + set endrec [binary format a4ssssiis PK\05\06 0 0 \ + $count $count [string length $cd] $cdoffset\ + [string length $opts(-comment)]] + append endrec $opts(-comment) + puts -nonewline $zf $cd + puts -nonewline $zf $endrec + close $zf + + set result "" + switch -exact -- $opts(-return) { + list { + set result $members + } + pretty { + if {[info commands showlist] ne ""} { + set result [plist -channel none members] + } else { + set result $members + } + } + none { + set result "" + } + } + return $result + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::zip ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::zip::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::zip::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::zip::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::zip::system { + #*** !doctools + #[subsection {Namespace punk::zip::system}] + #[para] Internal functions that are not part of the API + + + +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::zip [tcl::namespace::eval punk::zip { + variable pkg punk::zip + 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/zip-0.1.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm new file mode 100644 index 00000000..99bc359d --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm @@ -0,0 +1,861 @@ +# -*- 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) 2024 JMN +# (C) 2009 Path Thoyts +# +# @@ Meta Begin +# Application punk::zip 0.1.1 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::zip 0 0.1.1] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::zip] +#[keywords module zip fileformat] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::zip +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::zip +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::args}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::zip { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::zip}] + #[para] Core API functions for punk::zip + #[list_begin definitions] + + proc Path_a_atorbelow_b {path_a path_b} { + return [expr {[StripPath $path_b $path_a] ne $path_a}] + } + proc Path_a_at_b {path_a path_b} { + return [expr {[StripPath $path_a $path_b] eq "." }] + } + + proc Path_strip_alreadynormalized_prefixdepth {path prefix} { + if {$prefix eq ""} { + return $path + } + set pathparts [file split $path] + set prefixparts [file split $prefix] + if {[llength $prefixparts] >= [llength $pathparts]} { + return "" + } + return [file join \ + {*}[lrange \ + $pathparts \ + [llength $prefixparts] \ + end]] + } + + #StripPath - borrowed from tcllib fileutil + # ::fileutil::stripPath -- + # + # If the specified path references/is a path in prefix (or prefix itself) it + # is made relative to prefix. Otherwise it is left unchanged. + # In the case of it being prefix itself the result is the string '.'. + # + # Arguments: + # prefix prefix to strip from the path. + # path path to modify + # + # Results: + # path The (possibly) modified path. + + if {[string equal $::tcl_platform(platform) windows]} { + # Windows. While paths are stored with letter-case preserved al + # comparisons have to be done case-insensitive. For reference see + # SF Tcllib Bug 2499641. + + proc StripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal -nocase $prefix $npath]} { + return "." + } + + if {[string match -nocase "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } + } else { + proc StripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal $prefix $npath]} { + return "." + } + + if {[string match "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } + } + + proc Timet_to_dos {time_t} { + #*** !doctools + #[call [fun Timet_to_dos] [arg time_t]] + #[para] convert a unix timestamp into a DOS timestamp for ZIP times. + #[example { + # DOS timestamps are 32 bits split into bit regions as follows: + # 24 16 8 0 + # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ + # |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| + # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ + #}] + set s [clock format $time_t -format {%Y %m %e %k %M %S}] + scan $s {%d %d %d %d %d %d} year month day hour min sec + expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) + | ($hour << 11) | ($min << 5) | ($sec >> 1)} + } + + proc walk {args} { + #*** !doctools + #[call [fun walk] [arg ?options?] [arg base]] + #[para] Walk a directory tree rooted at base + #[para] the -excludes list can be a set of glob expressions to match against files and avoid + #[para] e.g + #[example { + # punk::zip::walk -exclude {CVS/* *~.#*} library + #}] + + #todo: -relative 0|1 flag? + set argd [punk::args::get_dict { + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -help\ + "Walk the directory structure starting at base/<-subpath> + and return a list of the files and folders encountered. + Resulting paths are relative to base unless -resultrelative + is supplied. + Folder names will end with a trailing slash. + " + -resultrelative -optional 1 -help\ + "Resulting paths are relative to this value. + Defaults to the value of base. If empty string + is given to -resultrelative the paths returned + are effectively absolute paths." + -emptydirs -default 0 -type boolean -help\ + "Whether to include directory trees in the result which had no + matches for the given fileglobs. + Intermediate dirs are always returned if there is a match with + fileglobs further down even if -emptdirs is 0. + " + -excludes -default "" -help "list of glob expressions to match against files and exclude" + -subpath -default "" -help\ + "May contain glob chars for folder elements" + @values -min 1 -max -1 + base + fileglobs -default {*} -multiple 1 + } $args] + set base [dict get $argd values base] + set fileglobs [dict get $argd values fileglobs] + set subpath [dict get $argd opts -subpath] + set excludes [dict get $argd opts -excludes] + set emptydirs [dict get $argd opts -emptydirs] + + set received [dict get $argd received] + + set imatch [list] + foreach fg $fileglobs { + lappend imatch [file join $subpath $fg] + } + + if {![dict exists $received -resultrelative]} { + set relto $base + set prefix "" + } else { + set relto [file normalize [dict get $argd opts -resultrelative]] + if {$relto ne ""} { + if {![Path_a_atorbelow_b $base $relto]} { + error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)" + } + set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto] + } else { + set prefix $base + } + } + + set result {} + #set imatch [file join $subpath $match] + set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] + foreach file $files { + set excluded 0 + foreach glob $excludes { + if {[string match $glob $file]} { + set excluded 1 + break + } + } + if {!$excluded} {lappend result [file join $prefix $file]} + } + foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { + set submatches [walk -subpath $dir -emptydirs $emptydirs -excludes $excludes $base {*}$fileglobs] + set subdir_entries [list] + set thisdir_match [list] + set has_file 0 + foreach sd $submatches { + set fullpath [file join $prefix $sd] ;#file join destroys trailing slash + if {[string index $sd end] eq "/"} { + lappend subdir_entries $fullpath/ + } else { + set has_file 1 + lappend subdir_entries $fullpath + } + } + if {$emptydirs} { + set thisdir_match [list "[file join $prefix $dir]/"] + } else { + if {$has_file} { + set thisdir_match [list "[file join $prefix $dir]/"] + } else { + set subdir_entries [list] + } + } + #NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" + #This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash + #Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. + set result [list {*}$result {*}$thisdir_match {*}$subdir_entries] + } + return $result + } + + #if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) + #Otherwise extract an internal preamble. + #if neither - + #review - reconsider auto-determination of internal vs external preamble + proc extract_preamble {infile outfile_preamble {outfile_zip ""}} { + set inzip [open $infile r] + fconfigure $inzip -encoding iso8859-1 -translation binary + if {[file exists $outfile_preamble]} { + error "outfile_preamble $outfile_preamble already exists - please remove first" + } + if {$outfile_zip ne ""} { + if {[file exists $outfile_zip] && [file size $outfile_zip]} { + error "outfile_zip $outfile_zip already exists - please remove first" + } + } + chan seek $inzip 0 end + set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent + chan seek $inzip 0 start + #only scan last 64k - cover max signature size?? review + if {$insize < 65559} { + set tailsearch_start 0 + } else { + set tailsearch_start [expr {$insize - 65559}] + } + chan seek $inzip $tailsearch_start start + set scan [read $inzip] + #EOCD - End Of Central Directory record + set start_of_end [string last "\x50\x4b\x05\x06" $scan] + puts stdout "==>start_of_end: $start_of_end" + + if {$start_of_end == -1} { + #no zip eocdr - consider entire file to be the zip preamble + set baseoffset $insize + } else { + set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] + chan seek $inzip $filerelative_eocd_posn + set cdir_record_plus [read $inzip] ;#can have trailing data + binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + #rule out a false positive from within a nonzip (e.g plain exe) + #There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. + #It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway + #we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros + #todo - just search for Pk\5\6\0\0\0\0 in the first place? //review + if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { + #review - should keep searching? + #for now we assume not a zip + set baseoffset $insize + } else { + #use the central dir size to jump back tko start of central dir + #determine if diroffset is file or archive relative + + set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] + puts stdout "---> [read $inzip 4]" + if {$filerelative_cdir_start > $eocd(diroffset)} { + #'external preamble' easy case + # - ie 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier + #though we are assuming zip offsets are not corrupted + set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] + } else { + #'internal preamble' hard case + # - either no preamble - or offsets have been adjusted to be file relative. + #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers + #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? + #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete + + #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) + #we can't assume they're ordered in any particular way - so we in theory have to look at them all. + set baseoffset "unknown" + chan seek $inzip $filerelative_cdir_start start + #binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + # eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + #load the whole central dir into cdir + + #todo! loop through all cdr file headers - find highest offset? + #tclZipfs.c just looks at first file header in Central Directory + #looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW + + set cdirdata [read $inzip $eocd(dirsize)] + binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ + cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ + cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) + + #since we're in this branch - we assume cdir(relativeoffset) is from the start of the file + chan seek $inzip $cdir(relativeoffset) + #let's at least check that we landed on a local file header.. + set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field + binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ + lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) + #dec2hex 67324752 = 4034B50 = PK\3\4 + puts stdout "1st local file header sig: $lfh(signature)" + if {$lfh(signature) == 67324752} { + #looks like a local file header + #use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) + set baseoffset $cdir(relativeoffset) + } + } + puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" + } + } + puts stdout "baseoffset: $baseoffset" + #expect CDFH PK\1\2 + #above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) + #above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script + + if {![string is integer -strict $baseoffset]} { + error "unable to determine zip baseoffset of file $infile" + } + + if {$baseoffset < $insize} { + set pout [open $outfile_preamble w] + fconfigure $pout -encoding iso8859-1 -translation binary + chan seek $inzip 0 start + chan copy $inzip $pout -size $baseoffset + close $pout + if {$outfile_zip ne ""} { + #todo - if it was internal preamble - need to adjust offsets to fix the split off zipfile + set zout [open $outfile_zip w] + fconfigure $zout -encoding iso8859-1 -translation binary + chan copy $inzip $zout + close $zout + } + close $inzip + } else { + #no valid (from our perspective) eocdr found - baseoffset has been set to insize + close $inzip + file copy $infile $outfile_preamble + if {$outfile_zip ne ""} { + #touch equiv? + set fd [open $outfile_zip w] + close $fd + } + } + } + + + + # Addentry - was Mkzipfile -- + # + # FIX ME: should handle the current offset for non-seekable channels + # + proc Addentry {args} { + #*** !doctools + #[call [fun Addentry] [arg zipchan] [arg base] [arg path] [arg ?comment?]] + #[para] Add a single file to a zip archive + #[para] The zipchan channel should already be open and binary. + #[para] You can provide a -comment for the file. + #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. + + set argd [punk::args::get_dict { + @id -id ::punk::zip::Addentry + @cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + return a central directory file record" + @opts + -comment -default "" -help "An optional comment specific to the added file" + @values -min 3 -max 4 + zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" + base -help "base path for entries" + path -type file -help "path of file to add" + zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe + Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" + } $args] + + set zipchan [dict get $argd values zipchan] + set base [dict get $argd values base] + set path [dict get $argd values path] + set zipdataoffset [dict get $argd values zipdataoffset] + + set comment [dict get $argd opts -comment] + + set fullpath [file join $base $path] + set mtime [Timet_to_dos [file mtime $fullpath]] + set utfpath [encoding convertto utf-8 $path] + set utfcomment [encoding convertto utf-8 $comment] + set flags [expr {(1<<11)}] ;# utf-8 comment and path + set method 0 ;# store 0, deflate 8 + set attr 0 ;# text or binary (default binary) + set version 20 ;# minumum version req'd to extract + set extra "" + set crc 0 + set size 0 + set csize 0 + set data "" + set seekable [expr {[tell $zipchan] != -1}] + if {[file isdirectory $fullpath]} { + set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) + #set attrex 0x40000010 + } elseif {[file executable $fullpath]} { + set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) + } else { + set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) + if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { + set attr 1 ;# text + } + } + + if {[file isfile $fullpath]} { + set size [file size $fullpath] + if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} + } + + + set channeloffset [tell $zipchan] ;#position in the channel - this may include prefixing exe/zip + set local [binary format a4sssiiiiss PK\03\04 \ + $version $flags $method $mtime $crc $csize $size \ + [string length $utfpath] [string length $extra]] + append local $utfpath $extra + puts -nonewline $zipchan $local + + if {[file isfile $fullpath]} { + # If the file is under 2MB then zip in one chunk, otherwize we use + # streaming to avoid requiring excess memory. This helps to prevent + # storing re-compressed data that may be larger than the source when + # handling PNG or JPEG or nested ZIP files. + if {$size < 0x00200000} { + set fin [open $fullpath rb] + set data [read $fin] + set crc [zlib crc32 $data] + set cdata [zlib deflate $data] + if {[string length $cdata] < $size} { + set method 8 + set data $cdata + } + close $fin + set csize [string length $data] + puts -nonewline $zipchan $data + } else { + set method 8 + set fin [open $fullpath rb] + set zlib [zlib stream deflate] + while {![eof $fin]} { + set data [read $fin 4096] + set crc [zlib crc32 $data $crc] + $zlib put $data + if {[string length [set zdata [$zlib get]]]} { + incr csize [string length $zdata] + puts -nonewline $zipchan $zdata + } + } + close $fin + $zlib finalize + set zdata [$zlib get] + incr csize [string length $zdata] + puts -nonewline $zipchan $zdata + $zlib close + } + + if {$seekable} { + # update the header if the output is seekable + set local [binary format a4sssiiii PK\03\04 \ + $version $flags $method $mtime $crc $csize $size] + set current [tell $zipchan] + seek $zipchan $channeloffset + puts -nonewline $zipchan $local + seek $zipchan $current + } else { + # Write a data descriptor record + set ddesc [binary format a4iii PK\7\8 $crc $csize $size] + puts -nonewline $zipchan $ddesc + } + } + + #PK\x01\x02 Cdentral directory file header + #set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 + set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) + + set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ + $version $flags $method $mtime $crc $csize $size \ + [string length $utfpath] [string length $extra]\ + [string length $utfcomment] 0 $attr $attrex [expr {$channeloffset - $zipdataoffset}]] ;#zipdataoffset may be zero - either because it's a pure zip, or file-based offsets desired. + append hdr $utfpath $extra $utfcomment + return $hdr + } + + #### REVIEW!!! + #JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') + # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) + #### + + # zip::mkzip -- + # + # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt + # + proc mkzip {args} { + #todo - doctools - [arg ?globs...?] syntax? + + #*** !doctools + #[call [fun mkzip]\ + # [opt "[option -offsettype] [arg offsettype]"]\ + # [opt "[option -return] [arg returntype]"]\ + # [opt "[option -zipkit] [arg 0|1]"]\ + # [opt "[option -runtime] [arg preamble_filename]"]\ + # [opt "[option -comment] [arg zipfilecomment]"]\ + # [opt "[option -directory] [arg dir_to_zip]"]\ + # [opt "[option -base] [arg archive_root]"]\ + # [opt "[option -exclude] [arg globlist]"]\ + # [arg zipfilename]\ + # [arg ?glob...?]] + #[para] Create a zip archive in 'zipfilename' + #[para] If a file already exists, an error will be raised. + #[para] Call 'punk::zip::mkzip' with no arguments for usage display. + + set argd [punk::args::get_dict { + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ + -help "Create a zip archive in 'filename'" + @opts + -offsettype -default "archive" -choices {archive file}\ + -help "zip offsets stored relative to start of entire file or relative to start of zip-archive + Only relevant if the created file has a script/runtime prefix. + " + -return -default "pretty" -choices {pretty list none}\ + -help "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal + " + -zipkit -default 0 -type none\ + -help "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs + " + -runtime -default ""\ + -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review) + " + -comment -default ""\ + -help "An optional comment for the archive" + -directory -default ""\ + -help "The new zip archive will scan for contents within this folder or current directory if not provided. + Note that this will + " + -base -default ""\ + -help "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory or the same path as -directory" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + + @values -min 1 -max -1 + filename -type file -default ""\ + -help "name of zipfile to create" + globs -default {*} -multiple 1\ + -help "list of glob patterns to match. + Only directories with matching files will be included in the archive." + } $args] + + set filename [dict get $argd values filename] + if {$filename eq ""} { + error "mkzip filename cannot be empty string" + } + if {[regexp {[?*]} $filename]} { + #catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name + error "mkzip filename should not contain glob characters ? *" + } + if {[file exists $filename]} { + error "mkzip filename:$filename already exists" + } + dict for {k v} [dict get $argd opts] { + switch -- $k { + -comment { + dict set argd opts $k [encoding convertto utf-8 $v] + } + -directory - -base { + dict set argd opts $k [file normalize $v] + } + } + } + + array set opts [dict get $argd opts] + + + if {$opts(-directory) ne ""} { + if {$opts(-base) ne ""} { + #-base and -directory have been normalized already + if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { + error "punk::zip::mkzip -base $opts(-base) must be above or the same as -directory $opts(-directory)" + } + set base $opts(-base) + set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] + } else { + set base $opts(-directory) + set relpath "" + } + #will pick up intermediary folders as paths (ending with trailing slash) + set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] + + set norm_filename [file normalize $filename] + set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) + if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { + #check that we aren't adding the zipfile to itself + #REVIEW - now that we open zipfile after scanning - this isn't really a concern! + #keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) + #In the case of -force - we may want to delay replacement of original until scan is done? + + #try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each + #1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths + set self_globs_match 0 + foreach g [dict get $argd values globs] { + if {[string match $g [file tail $filename]]} { + set self_globs_match 1 + break + } + } + if {$self_globs_match} { + #still dangerous + set self_excluded 0 + foreach e $opts(-exclude) { + if {[string match $e [file tail $filename]]} { + set self_excluded 1 + break + } + } + if {!$self_excluded} { + #still dangerous - likely to be in resultset - check each path + #puts stderr "zip file $filename is below directory $opts(-directory)" + set self_is_matched 0 + set i 0 + foreach p $paths { + set norm_p [file normalize [file join $opts(-directory) $p]] + if {[Path_a_at_b $norm_filename $norm_p]} { + set self_is_matched 1 + break + } + incr i + } + if {$self_is_matched} { + puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" + set paths [lremove $paths $i] + } + } + } + } + } else { + #NOTE that we don't add intermediate folders when creating an archive without using the -directory flag! + #ie - only the exact *files* matching the glob are stored. + set paths [list] + set dir [pwd] + if {$opts(-base) ne ""} { + if {![Path_a_atorbelow_b $dir $opts(-base)]} { + error "punk::zip::mkzip -base $opts(-base) must be above current directory" + } + set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] + } else { + set relpath "" + } + set base $opts(-base) + + set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] + foreach m $matches { + if {$m eq $filename} { + #puts stderr "--> excluding $filename" + continue + } + set isok 1 + foreach e [concat $opts(-exclude) $filename] { + if {[string match $e $m]} { + set isok 0 + break + } + } + if {$isok} { + lappend paths [file join $relpath $m] + } + } + } + + if {![llength $paths]} { + return "" + } + + set zf [open $filename wb] + if {$opts(-runtime) ne ""} { + #todo - strip any existing vfs - option to merge contents.. only if zip attached? + set rt [open $opts(-runtime) rb] + fcopy $rt $zf + close $rt + } elseif {$opts(-zipkit)} { + #TODO - update to zipfs ? + #see modpod + set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" + append zkd "package require vfs::zip\n" + append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" + append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" + append zkd " source \[file join \[info script\] main.tcl\]\n" + append zkd "}\n" + append zkd \x1A + puts -nonewline $zf $zkd + } + + #todo - subtract this from the endrec offset + if {$opts(-offsettype) eq "archive"} { + set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024 + } else { + set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/ + } + + set count 0 + set cd "" + + set members [list] + foreach path $paths { + #puts $path + lappend members $path + append cd [Addentry $zf $base $path $dataStartOffset] ;#path already includes relpath + incr count + } + set cdoffset [tell $zf] + set endrec [binary format a4ssssiis PK\05\06 0 0 \ + $count $count [string length $cd] [expr {$cdoffset - $dataStartOffset}]\ + [string length $opts(-comment)]] + append endrec $opts(-comment) + puts -nonewline $zf $cd + puts -nonewline $zf $endrec + close $zf + + set result "" + switch -exact -- $opts(-return) { + list { + set result $members + } + pretty { + if {[info commands showlist] ne ""} { + set result [plist -channel none members] + } else { + set result $members + } + } + none { + set result "" + } + } + return $result + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::zip ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::zip::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::zip::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::zip::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::zip [tcl::namespace::eval punk::zip { + variable pkg punk::zip + variable version + set version 0.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punkapp-0.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punkapp-0.1.tm new file mode 100644 index 00000000..70fa90fc --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punkapp-0.1.tm @@ -0,0 +1,239 @@ +#utilities for punk apps to call + +package provide punkapp [namespace eval punkapp { + variable version + set version 0.1 +}] + +namespace eval punkapp { + variable result + variable waiting "no" + proc hide_dot_window {} { + #alternative to wm withdraw . + #see https://wiki.tcl-lang.org/page/wm+withdraw + wm geometry . 1x1+0+0 + wm overrideredirect . 1 + wm transient . + } + proc is_toplevel {w} { + if {![llength [info commands winfo]]} { + return 0 + } + expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} + } + proc get_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list {} + if {[is_toplevel $w]} { + lappend list $w + } + foreach w [winfo children $w] { + lappend list {*}[get_toplevels $w] + } + return $list + } + + proc make_toplevel_next {prefix} { + set top [get_toplevel_next $prefix] + return [toplevel $top] + } + #possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime + #todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? + #can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix + proc get_toplevel_next {prefix} { + set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" + + + + } + proc exit {{toplevel ""}} { + variable waiting + variable result + variable default_result + set toplevels [get_toplevels] + if {[string length $toplevel]} { + set wposn [lsearch $toplevels $toplevel] + if {$wposn > 0} { + destroy $toplevel + } + } else { + #review + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "punkapp::exit called without toplevel - showing console" + show_console + return 0 + } else { + puts stderr "punkapp::exit called without toplevel - exiting" + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + + set controllable [get_user_controllable_toplevels] + if {![llength $controllable]} { + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + show_console + } else { + if {$waiting ne "no"} { + if {[info exists result(shell)]} { + set temp [set result(shell)] + unset result(shell) + set waiting $temp + } elseif {[info exists result($toplevel)]} { + set temp [set result($toplevel)] + unset result($toplevel) + set waiting $temp + } elseif {[info exists default_result]} { + set temp $default_result + unset default_result + set waiting $temp + } else { + set waiting "" + } + } else { + ::exit + } + } + } + } + proc close_window {toplevel} { + wm withdraw $toplevel + if {![llength [get_user_controllable_toplevels]]} { + punkapp::exit $toplevel + } + destroy $toplevel + } + proc wait {args} { + variable waiting + variable default_result + if {[dict exists $args -defaultresult]} { + set default_result [dict get $args -defaultresult] + } + foreach t [punkapp::get_toplevels] { + if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { + wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] + } + } + if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { + puts stderr "repl eventloop seems to be running - punkapp::wait not required" + } else { + if {$waiting eq "no"} { + set waiting "waiting" + vwait ::punkapp::waiting + return $::punkapp::waiting + } + } + } + + #A window can be 'visible' according to this - but underneath other windows etc + #REVIEW - change name? + proc get_visible_toplevels {{w .}} { + if {![llength [info commands winfo]]} { + return [list] + } + set list [get_toplevels $w] + set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] + set mapped [concat {*}$mapped] ;#ignore {} + set visible [list] + foreach m $mapped { + if {[wm overrideredirect $m] == 0 } { + lappend visible $m + } else { + if {[winfo height $m] >1 && [winfo width $m] > 1} { + #technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 + #as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible + lappend visible $m + } + } + } + return $visible + } + proc get_user_controllable_toplevels {{w .}} { + set visible [get_visible_toplevels $w] + set controllable [list] + foreach v $visible { + if {[wm overrideredirect $v] == 0} { + lappend controllable $v + } + } + #only return visible windows with overrideredirect == 0 because there exists some user control. + #todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily + return $controllable + } + proc hide_console {args} { + set opts [dict create -force 0] + if {([llength $args] % 2) != 0} { + error "hide_console expects pairs of arguments. e.g -force 1" + } + #set known_opts [dict keys $defaults] + foreach {k v} $args { + switch -- $k { + -force { + dict set opts $k $v + } + default { + error "Unrecognised options '$k' known options: [dict keys $opts]" + } + } + } + set force [dict get $opts -force] + + if {!$force} { + if {![llength [get_user_controllable_toplevels]]} { + puts stderr "Cannot hide console while no user-controllable windows available" + return 0 + } + } + if {$::tcl_platform(platform) eq "windows"} { + #hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. + #It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. + #an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. + #(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) + package require twapi + set h [twapi::get_console_window] + set pid [twapi::get_window_process $h] + set pinfo [twapi::get_process_info $pid -name] + set pname [dict get $pinfo -name] + set wstyle [twapi::get_window_style $h] + #tclkitsh/tclsh? + if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { + twapi::hide_window $h + return 1 + } else { + puts stderr "punkapp::hide_console unable to hide this type of console window" + return 0 + } + } else { + #todo + puts stderr "punkapp::hide_console unimplemented on this platform (todo)" + return 0 + } + } + + proc show_console {} { + if {$::tcl_platform(platform) eq "windows"} { + package require twapi + if {![catch {set h [twapi::get_console_window]} errM]} { + twapi::show_window $h -activate -normal + } else { + #no console - assume launched from something like wish? + catch {console show} + } + } else { + #todo + puts stderr "punkapp::show_console unimplemented on this platform" + } + } + +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm index 10ca3a32..a4113c45 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm @@ -69,7 +69,7 @@ namespace eval punkcheck { } - proc load_records_from_file {punkcheck_file} { + proc load_records_from_file {punkcheck_file} { set record_list [list] if {[file exists $punkcheck_file]} { set tdlscript [punk::mix::util::fcat $punkcheck_file] @@ -86,7 +86,7 @@ namespace eval punkcheck { set linecount [llength [split $newtdl \n]] #puts stdout $newtdl set fd [open $punkcheck_file w] - fconfigure $fd -translation binary + chan configure $fd -translation binary puts -nonewline $fd $newtdl close $fd return [list recordcount [llength $recordlist] linecount $linecount] @@ -94,7 +94,7 @@ namespace eval punkcheck { #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? - #an installtrack objects represents an installation path from sourceroot to targetroot + #an installtrack objects represents an installation path from sourceroot to targetroot #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. # set objname [namespace current]::installtrack @@ -104,7 +104,7 @@ namespace eval punkcheck { #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD #each FILEINFO body being a list of SOURCE records oo::class create targetset { - variable o_targets + variable o_targets variable o_keep_installrecords variable o_keep_skipped variable o_keep_inprogress @@ -132,7 +132,7 @@ namespace eval punkcheck { -keep_inprogress $o_keep_inprogress\ body $o_records } - + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS method get_last_record {fileset_record} { set body [dict_getwithdefault $fileset_record body [list]] @@ -189,11 +189,11 @@ namespace eval punkcheck { } set o_ts_end [dict get $opts -tsend] set o_types [dict get $opts -types] - set o_configdict [dict get $opts -config] + set o_configdict [dict get $opts -config] set o_rel_sourceroot $rel_sourceroot set o_rel_targetroot $rel_targetroot - } + } destructor { #puts "[self] destructor called" } @@ -243,12 +243,14 @@ namespace eval punkcheck { } method get_targets_exist {} { set punkcheck_folder [file dirname [$o_installer get_checkfile]] - set existing [list] - foreach t $o_targets { - if {[file exists [file join $punkcheck_folder $t]]} { - lappend existing $t - } - } + set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets] + + #set existing [list] + #foreach t $o_targets { + # if {[file exists [file join $punkcheck_folder $t]]} { + # lappend existing $t + # } + #} return $existing } method end {} { @@ -339,14 +341,14 @@ namespace eval punkcheck { set installing_record [lindex $fileinfo_body end] set ts_start [dict get $installing_record -ts] - set ts_now [clock microseconds] + set ts_now [clock microseconds] set metadata_us [expr {$ts_now - $ts_start}] dict set installing_record -metadata_us $metadata_us dict set installing_record -ts_start_transfer $ts_now lset fileinfo_body end $installing_record - + return [dict set o_fileset_record body $fileinfo_body] } else { #legacy call @@ -359,7 +361,7 @@ namespace eval punkcheck { -note \uFFFF\ ] set known_opts [dict keys $defaults] - if {[llength $args] % 2 != 0} { + if {[llength $args] % 2} { error "targetset_end arguments after status must be in the form of -flag value pairs. known flags: $known_opts" } set opts [dict merge $defaults $args] @@ -368,7 +370,7 @@ namespace eval punkcheck { } set status [string toupper $status] - set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] if {$o_operation_start_ts eq ""} { error "[self] targetset_end $status - no current operation - call targetset_started first" } @@ -383,7 +385,7 @@ namespace eval punkcheck { error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" } set operation_end_ts [clock microseconds] - set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] set file_record_body [dict get $o_fileset_record body] set installing_record [lindex $file_record_body end] set punkcheck_file [$o_installer get_checkfile] @@ -414,12 +416,12 @@ namespace eval punkcheck { } } set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] - dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -targets_cksums $new_targets_cksums dict set installing_record -cksum_all_opts $cksum_all_opts dict set installing_record -cksum_us $cksum_us } lset file_record_body end $installing_record - dict set o_fileset_record body $file_record_body + dict set o_fileset_record body $file_record_body set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] @@ -436,8 +438,8 @@ namespace eval punkcheck { set o_operation "" return $o_fileset_record } - #can supply empty cksum value - # - that will influence the opts used if there is no existing install record + #can supply empty cksum value + # - that will influence the opts used if there is no existing install record method targetset_cksumcache_set {path_cksum_dict} { set o_path_cksum_cache $path_cksum_dict } @@ -504,12 +506,12 @@ namespace eval punkcheck { variable o_ts variable o_keep_events variable o_checkfile - variable o_sourceroot + variable o_sourceroot variable o_rel_sourceroot variable o_targetroot variable o_rel_targetroot variable o_record_list - variable o_active_event + variable o_active_event variable o_events constructor {installername punkcheck_file} { set o_active_event "" @@ -546,7 +548,7 @@ namespace eval punkcheck { #$o_events add $e [dict get $e -id] $o_events add $eobj [dict get $e -id] } - + } destructor { #puts "[self] destructor called" @@ -562,7 +564,7 @@ namespace eval punkcheck { } #call set_source_target before calling start_event/end_event - #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. method set_source_target {sourceroot targetroot} { if {[file pathtype $sourceroot] ne "absolute"} { error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" @@ -605,7 +607,7 @@ namespace eval punkcheck { } method save_installer_record {} { set file_records [punkcheck::load_records_from_file $o_checkfile] - + set this_installer_record [my as_record] set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] @@ -658,13 +660,13 @@ namespace eval punkcheck { set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] } method get_recordlist {} { - return $o_recordlist + return $o_recordlist } method end_event {} { if {$o_active_event eq ""} { error "[self] end_event error - no active event" } - $o_active_event end + $o_active_event end } method get_event {} { return $o_active_event @@ -720,7 +722,7 @@ namespace eval punkcheck { append msg "Call in order:" \n append msg " start_installer_event (get dict with eventid and recordset keys)" append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n - append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n append msg " ( - possibly with same algorithm as previous installrecord)" \n append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n append msg "Finalize by calling:" \n @@ -749,7 +751,7 @@ namespace eval punkcheck { set punkcheck_file [file join $punkcheck_folder/.punkcheck] set record_list [load_records_from_file $punkcheck_file] - + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] set installer_record_position [dict get $resultinfo position] if {$installer_record_position == -1} { @@ -805,7 +807,7 @@ namespace eval punkcheck { #validate any passed cached_cksums foreach cacheinfo $cached_cksums { if {[llength $cacheinfo] % 2 != 0} { - error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" + error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" } dict for {k v} $cacheinfo { switch -- $k { @@ -814,7 +816,7 @@ namespace eval punkcheck { #todo - validate $v keys } default { - error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" + error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" } } @@ -837,7 +839,7 @@ namespace eval punkcheck { } } } - #check that this relpath not already added as child of *-INPROGRESS + #check that this relpath not already added as child of *-INPROGRESS set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body set installing_record [lindex $file_record_body end] set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] @@ -871,28 +873,55 @@ namespace eval punkcheck { #use first entry in cached_cksums if we can if {[llength $cached_cksums]} { set use_cache 1 - set use_cache_record [lindex $cached_cksums 0] + set use_cache_record [lindex $cached_cksums 0] } } #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) #if same cksum_opts - then use cached data instead of checksumming here. - #allow nonexistant as a source + #allow nonexistant as a source set fpath [file join $punkcheck_folder $source_relpath] - if {![file exists $fpath]} { + #windows: file exist + file type = 2ms vs 500ms for 2x glob + set floc [file dirname $fpath] + set fname [file tail $fpath] + set file_set [glob -nocomplain -dir $floc -type f -tails $fname] + set dir_set [glob -nocomplain -dir $floc -type d -tails $fname] + set link_set [glob -nocomplain -dir $floc -type l -tails $fname] + if {[llength $file_set] == 0 && [llength $dir_set] == 0 && [llength $link_set] == 0} { + #could also theoretically exist as less common types, b,c,p,s (block,char,pipe,socket) + #- we don't expect them here - REVIEW - ever possible? + #- installing/examining such things an unlikely usecase and would require special handling anyway. set ftype "missing" set fsize "" } else { - set ftype [file type $fpath] - if {$ftype eq "directory"} { + if {[llength $dir_set]} { + set ftype "directory" set fsize "NA" + } elseif {[llength $link_set]} { + set ftype "link" + set fsize 0 } else { + set ftype "file" #todo - optionally use mtime instead of cksum (for files only)? #mtime is not reliable across platforms and filesystems though.. see article linked at top. set fsize [file size $fpath] } } + + #if {![file exists $fpath]} { + # set ftype "missing" + # set fsize "" + #} else { + # set ftype [file type $fpath] + # if {$ftype eq "directory"} { + # set fsize "NA" + # } else { + # #todo - optionally use mtime instead of cksum (for files only)? + # #mtime is not reliable across platforms and filesystems though.. see article linked at top. + # set fsize [file size $fpath] + # } + #} #get_relativecksum_from_base and fill_relativecksums_from_base_and_relativepathdict will set cksum to if fpath doesn't exist if {$use_cache} { set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $punkcheck_folder [dict create $source_relpath $use_cache_record]] @@ -914,7 +943,7 @@ namespace eval punkcheck { set changed 0 } set installing_record_sources [dict_getwithdefault $installing_record body [list]] - set ts_now [clock microseconds] ;#gathering metadata - especially checsums on folder can take some time - calc and store elapsed us for time taken to gather metadata + set ts_now [clock microseconds] ;#gathering metadata - especially checksums on folder can take some time - calc and store elapsed us for time taken to gather metadata set metadata_us [expr {$ts_now - $ts_start}] set this_source_record [dict create tag SOURCE -type $ftype -size $fsize -path $source_relpath -cksum $cksum -cksum_all_opts $cksum_all_opts -changed $changed -metadata_us $metadata_us] lappend installing_record_sources $this_source_record @@ -939,14 +968,14 @@ namespace eval punkcheck { set installing_record [lindex $file_record_body end] set ts_start [dict get $installing_record -ts] - set ts_now [clock microseconds] + set ts_now [clock microseconds] set metadata_us [expr {$ts_now - $ts_start}] - + dict set installing_record -metadata_us $metadata_us dict set installing_record -ts_start_transfer $ts_now lset file_record_body end $installing_record - + dict set file_record body $file_record_body @@ -983,7 +1012,7 @@ namespace eval punkcheck { dict set installing_record tag "INSTALL-RECORD" lset file_record_body end $installing_record - dict set file_record body $file_record_body + dict set file_record body $file_record_body set file_record [punkcheck::recordlist::file_record_prune $file_record] @@ -1016,8 +1045,8 @@ namespace eval punkcheck { set tsnow [clock microseconds] set elapsed_us [expr {$tsnow - $ts_start}] dict set installing_record -elapsed_us $elapsed_us - dict set installing_record tag "INSTALL-SKIPPED" - + dict set installing_record tag "INSTALL-SKIPPED" + lset file_record_body end $installing_record dict set file_record body $file_record_body @@ -1076,7 +1105,7 @@ namespace eval punkcheck { #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL proc install_record_get_matching_source_record {install_record source_relpath} { - set body [dict_getwithdefault $install_record body [list]] + set body [dict_getwithdefault $install_record body [list]] foreach src $body { if {[dict get $src tag] eq "SOURCE"} { if {[dict_getwithdefault $src -path ""] eq $source_relpath} { @@ -1124,7 +1153,7 @@ namespace eval punkcheck { set do_normalize 1 } } else { - #case differences in volumes is common on windows + #case differences in volumes is common on windows set do_normalize 1 } if {$do_normalize} { @@ -1170,6 +1199,7 @@ namespace eval punkcheck { } #skip writing punkcheck during checksum/timestamp checks + #todo - punk::args - fetch from punkcheck::install (with overrides) proc install_tm_files {srcdir basedir args} { set defaults [list\ -glob *.tm\ @@ -1206,19 +1236,77 @@ namespace eval punkcheck { if {[dict exists $dictValue {*}$keys]} { return [dict get $dictValue {*}$keys] } else { - return [lindex $args end] + return [lindex $args end] } } + lappend PUNKARGS [list { + @id -id ::punkcheck::install + @cmd -name ::punkcheck::install -help\ + "Unidirectional file transfer to possibly non-empty target folder." + @leaders -min 2 -max 2 + srcdir -type directory + tgtdir -type directory + -call-depth-internal -type integer -default 0 -help "(internal recursion tracker)" + -subdirlist -type list -default "" -help "(primarily internal - length generally matching -call-depth-internal)" + -max_depth -type integer -default 1000 -help\ + "Deepest subdirectory - use -1 for no limit." + -createdir -type boolean -default 0 -help\ + "Whether to create the folder at tgtdir. + Any required subdirectories are created regardless of this setting." + -createempty -type boolean -default 0 -help\ + "Whether to create folders at target that had no matches for our glob" + -glob -type string -default "*" -help\ + "Pattern matching for source file(s) to copy. Can be glob based or exact match." + -antiglob_file_core -default {${[::punkcheck::default_antiglob_file_core]}} + -antiglob_file -default "" + -antiglob_dir_core -default {${[::punkcheck::default_antiglob_dir_core]}} + -antiglob_dir -default "" + -antiglob_paths -default {} + -overwrite -default no-targets\ + -choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\ + -choicecolumns 1\ + -choicelabels { + no-targets "only copy files that are missing at the target" + newer-targets "copy files with older source timestamp over newer + target timestamp and those missing at the target + (a form of 'restore' operation)" + older-targets "copy files with newer source timestamp over older + target timestamp and those missing at the target" + all-targets "copy regardless of timestamp at target" + installedsourcechanged-targets "copy if the target doesn't exist or the source changed" + synced-targets "copy if the target doesn't exist or the source changed + and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry" + } + -source_checksum -default comparestore -choicecolumns 3 -choices {compare store comparestore false true}\ + -choicelabels { + true "same as comparestore" + } + -punkcheck_folder -default target -choices {target source project} -choicerestricted 0 -help\ + "The location of the .punkcheck file to track installations and checksums. + The default value 'target' is generally recommended. + Can also be an absolute path to a folder." + -punkcheck_records -default "" -help\ + "Empty string or a parsed TDL records structure. + e.g + {tag FILEINFO - ... body { + {tag INSTALL-RECORD - ... body {}} + ... + }... + }" + -installer -default "punkcheck::install" -help\ + "A user nominated string that is stored in the .punkcheck file + This might be the name of a script or installation process." + }] ## unidirectional file transfer to possibly non empty folder #default of -overwrite no-targets will only copy files that are missing at the target # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target # -overwrite all-targets will copy regardless of timestamp at target - # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed - # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD targets_cksums entry + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry # review - timestamps unreliable - # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? - # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? # if such a content-mismatch - what default behaviour and what options would make sense? # probably it's reasonable that only all-targets would overwrite such files. @@ -1243,6 +1331,7 @@ namespace eval punkcheck { -max_depth 1000\ -subdirlist {}\ -createdir 0\ + -createempty 0\ -glob *\ -antiglob_file_core "\uFFFF"\ -antiglob_file "" \ @@ -1271,13 +1360,14 @@ namespace eval punkcheck { #(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree) #It comes from build_modules_from_source_to_base where we need to keep track of position relative to our targetdir starting point to handle submodules e.g pkg::something::mypkg-0.1.tm #It could have been handled with some other parameter such as -depth, but this -subdirlist mechanism, whilst perhaps not beautiful, is straightforward enough - #and may be less error prone than doing slightly more opaue path manipulations at each recursion level to determine where we started + #and may be less error prone than doing slightly more opaque path manipulations at each recursion level to determine where we started #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. - set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDPEPTH = 0 + set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDEPTH = 0 set max_depth [dict get $opts -max_depth] ;# -1 for no limit set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill set fileglob [dict get $opts -glob] set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting + set opt_createempty [dict get $opts -createempty] if {$CALLDEPTH == 0} { #expensive to normalize but we need to do it at least once @@ -1285,6 +1375,13 @@ namespace eval punkcheck { set tgtdir [file normalize $tgtdir] if {$createdir} { file mkdir $tgtdir + } else { + if {![file exists $tgtdir]} { + error "punkcheck::install base target dir:'$tgtdir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + } + if {([file type $srcdir] ni [list directory]) || ([file type $tgtdir] ni [list directory])} { + error "punkcheck::install requires source and target dirs to be of type 'directory' type current source: [file type $srcdir] type current target: [file type $tgtdir]" } #now the values we build from these will be properly cased } @@ -1301,7 +1398,7 @@ namespace eval punkcheck { if {[llength [file split $af]] > 1} { error "punkcheck::install received invalid -antiglob_file entry '$af'. -antiglob_file entries are meant to match to a file name at any level so cannot contain path separators" } - } + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_antiglob_dir_core [dict get $opts -antiglob_dir_core] if {$opt_antiglob_dir_core eq "\uFFFF"} { @@ -1315,7 +1412,7 @@ namespace eval punkcheck { if {[llength [file split $ad]] > 1} { error "punkcheck::install received invalid -antiglob_dir entry '$ad'. -antiglob_dir entries are meant to match to a directory name at any level so cannot contain path separators" } - } + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_antiglob_paths [dict get $opts -antiglob_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment @@ -1414,7 +1511,7 @@ namespace eval punkcheck { } else { set store_source_cksums 0 } - + @@ -1450,13 +1547,7 @@ namespace eval punkcheck { if {![file exists $current_source_dir]} { - error "copy_files_from_source_to_target current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" - } - if {![file exists $current_target_dir]} { - error "copy_files_from_source_to_target current target dir:'$current_target_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" - } - if {([file type $current_source_dir] ni [list directory]) || ([file type $current_target_dir] ni [list directory])} { - error "copy_files_from_source_to_target requires source and target dirs to be of type 'directory' type current source: [file type $current_source_dir] type current target: [file type $current_target_dir]" + error "punkcheck::install current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" } set files_copied [list] @@ -1483,12 +1574,12 @@ namespace eval punkcheck { } if {$suppress == 0} { lappend match_list $m - } + } } #sample .punkcheck file record (raw form) to make the code clearer #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist - #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS # #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { @@ -1500,10 +1591,16 @@ namespace eval punkcheck { # SOURCE -type file -path ../src/modules/jjjetc-999999.0a1.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3338 # } #} - - + + if {[llength $match_list]} { + #example - target dir has a file where there is a directory at the source + if {[file exists $current_target_dir] && ([file type $current_target_dir] ni [list directory])} { + error "punkcheck::install target subfolder $current_target_dir exists but is not of type 'directory'. Type current target folder: [file type $current_target_dir]" + } + } + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} - + #puts stdout "Current target dir: $current_target_dir" foreach m $match_list { @@ -1513,7 +1610,7 @@ namespace eval punkcheck { set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] set is_antipath 0 foreach antipath $opt_antiglob_paths { - #puts "testing file - globmatchpath $antipath vs $relative_source_path" + #puts "testing file - globmatchpath $antipath vs $relative_source_path" if {[punk::path::globmatchpath $antipath $relative_source_path]} { lappend antiglob_paths_matched $current_source_dir set is_antipath 1 @@ -1530,7 +1627,7 @@ namespace eval punkcheck { #puts stdout " rel_target: $punkcheck_target_relpath" - + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] #change to use extract_or_create_fileset_record ? set existing_filerec_posn [dict get $fetch_filerec_result position] @@ -1546,7 +1643,7 @@ namespace eval punkcheck { set filerec [dict get $fetch_filerec_result record] } set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] - + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. @@ -1562,7 +1659,7 @@ namespace eval punkcheck { #different volume or root } #Note this isn't a recordlist function - so it doesn't purely operate on the records - #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] @@ -1579,10 +1676,16 @@ namespace eval punkcheck { set is_skip 0 if {$overwrite_what eq "all-targets"} { + file mkdir $current_target_dir + #-------------------------------------------- + #sometimes we get the error: 'error copying "file1" to "file2": invalid argument' + #-------------------------------------------- + puts stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" file copy -force $current_source_dir/$m $current_target_dir lappend files_copied $current_source_dir/$m } else { if {![file exists $current_target_dir/$m]} { + file mkdir $current_target_dir file copy $current_source_dir/$m $current_target_dir set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] lappend files_copied $current_source_dir/$m @@ -1592,6 +1695,7 @@ namespace eval punkcheck { installedsourcechanged-targets { if {[llength $changed]} { #An unrecorded installation is considered a source change (from unknown/unrecorded source to recorded) + file mkdir $current_target_dir file copy -force $current_source_dir/$m $current_target_dir set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] lappend files_copied $current_source_dir/$m @@ -1619,13 +1723,14 @@ namespace eval punkcheck { set target_cksum_compare "norecord" } if {$is_target_unmodified_since_install} { + file mkdir $current_target_dir file copy -force $current_source_dir/$m $current_target_dir set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] lappend files_copied $current_source_dir/$m } else { #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it set is_skip 1 - puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" lappend files_skipped $current_source_dir/$m } } else { @@ -1642,6 +1747,12 @@ namespace eval punkcheck { } } } + #target dir was created as necessary if files matched above + #now ensure target dir exists if -createempty true + if {$opt_createempty && ![file exists $current_target_dir]} { + file mkdir $current_target_dir + } + set ts_now [clock microseconds] @@ -1650,7 +1761,7 @@ namespace eval punkcheck { #if {$store_source_cksums} { #} - set install_records [dict get $filerec body] + set install_records [dict get $filerec body] set current_install_record [lindex $install_records end] #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED if {$is_skip} { @@ -1712,7 +1823,7 @@ namespace eval punkcheck { set relative_source_path [file join $relative_source_dir $d] set is_antipath 0 foreach antipath $opt_antiglob_paths { - #puts "testing folder - globmatchpath $antipath vs $relative_source_path" + #puts "testing folder - globmatchpath $antipath vs $relative_source_path" if {[punk::path::globmatchpath $antipath $relative_source_path]} { lappend antiglob_paths_matched [file join $current_source_dir $d] #puts stdout "SKIPPING FOLDER $relative_source_path due to antiglob_path-match: $antipath " @@ -1723,12 +1834,11 @@ namespace eval punkcheck { if {$is_antipath} { continue } - - if {![file exists $current_target_dir/$d]} { - file mkdir $current_target_dir/$d - } - + #if {![file exists $current_target_dir/$d]} { + # file mkdir $current_target_dir/$d + #} + set sub_opts_1 [list\ -call-depth-internal [expr {$CALLDEPTH + 1}]\ @@ -1751,7 +1861,7 @@ namespace eval punkcheck { -punkcheck_folder $punkcheck_folder\ -punkcheck_eventid $punkcheck_eventid\ -punkcheck_records $punkcheck_records\ - ] + ] set sub_opts [dict merge $opts $sub_opts] set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] @@ -1761,7 +1871,7 @@ namespace eval punkcheck { lappend antiglob_paths_matched {*}[dict get $sub_result antiglob_paths_matched] set punkcheck_records [dict get $sub_result punkcheck_records] } - + if {[string match *store* $opt_source_checksum]} { #puts "subdirlist: $subdirlist" if {$CALLDEPTH == 0} { @@ -1772,7 +1882,7 @@ namespace eval punkcheck { #puts stdout ">>>>>>>>>>>>>>>>>>>" } else { #todo - write db INSTALLER record if -debug true - + } #puts stdout "sources_unchanged" #puts stdout "$sources_unchanged" @@ -1782,22 +1892,75 @@ namespace eval punkcheck { return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged antiglob_paths_matched $antiglob_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] } - proc summarize_install_resultdict {resultdict} { + + + lappend PUNKARGS [list { + @id -id ::punkcheck::summarize_install_resultdict + @cmd -name punkcheck::summarize_install_resultdict -help\ + "Emits a string summarizing a punkcheck resultdict, showing + how many items were copied, and the source, target locations" + @opts + -title -type string -default "" + -forcecolour -type boolean -default 0 -help\ + "When true, passes the forcecolour tag to punk::ansi functions. + This enables ANSI sgr colours even when colour + is off. (ignoring env(NO_COLOR)) + To disable colour - ensure the NO_COLOR env var is set, + or use: + namespace eval ::punk::console {variable colour_disabled 1}" + @values -min 1 -max 1 + resultdict -type dict + }] + proc summarize_install_resultdict {args} { + set argd [punk::args::parse $args withid ::punkcheck::summarize_install_resultdict] + lassign [dict values $argd] leaders opts values received + set title [dict get $opts -title] + set forcecolour [dict get $opts -forcecolour] + set resultdict [dict get $values resultdict] + + set has_ansi [expr {![catch {package require punk::ansi}]}] + if {$has_ansi} { + if {$forcecolour} { + set fc "forcecolour" + } else { + set fc "" + } + set R [punk::ansi::a] ;#reset + set LINE_COLOUR [punk::ansi::a+ {*}$forcecolour bold cyan] + set LOW_COLOUR [punk::ansi::a+ {*}$forcecolour bold green] + set HIGH_COLOUR [punk::ansi::a+ {*}$forcecolour bold yellow] + } else { + set R "" + set LINE_COLOUR "" + set LOW_COLOUR "" + set HIGH_COLOUR "" + } + set msg "" if {[dict size $resultdict]} { set copied [dict get $resultdict files_copied] - append msg "--------------------------" \n - append msg "[dict keys $resultdict]" \n + if {[llength $copied] == 0} { + set HIGHLIGHT $LOW_COLOUR + } else { + set HIGHLIGHT $HIGH_COLOUR + } + set ruler $LINE_COLOUR[string repeat - 78]$R + if {$title ne ""} { + append msg $ruler \n + append msg $title \n + } + append msg $ruler \n + #append msg "[dict keys $resultdict]" \n set tgtdir [dict get $resultdict tgtdir] set checkfolder [dict get $resultdict punkcheck_folder] - append msg "Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]" \n + append msg "${HIGHLIGHT}Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]$R" \n foreach f $copied { append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n append msg " TO $tgtdir" \n } append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n - append msg "--------------------------" \n + append msg $ruler \n } return $msg } @@ -2031,7 +2194,7 @@ namespace eval punkcheck { if {[dict get $file_record tag] ne "FILEINFO"} { error "file_record_set_defaults bad file_record: tag not FILEINFO" } - set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] foreach {k v} $defaults { if {![dict exists $file_record $k]} { dict set file_record $k $v @@ -2096,8 +2259,10 @@ namespace eval punkcheck { - - +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punkcheck +} @@ -2107,10 +2272,10 @@ namespace eval punkcheck { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punkcheck [namespace eval punkcheck { set pkg punkcheck 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/punkcheck/cli-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm new file mode 100644 index 00000000..bbf882a0 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punkcheck/cli-0.1.0.tm @@ -0,0 +1,335 @@ +# -*- 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 punkcheck::cli 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + +package require punk::mix::util + +namespace eval punkcheck::cli { + namespace ensemble create + #package require punk::overlay + #punk::overlay::import_commandset debug. ::punk:mix::commandset::debug + + #init proc required - used for lazy loading of commandsets + variable initialised 0 + proc _init {args} { + variable initialised + if {$initialised} { + return + } + puts stderr "punkcheck::cli::init $args" + + set initialised 1 + } + + proc help {args} { + set basehelp [punk::mix::base help {*}$args] + return $basehelp + } + + proc paths {{path {}}} { + if {$path eq {}} { set path [pwd] } + set search_from $path + set bottom_to_top [list] + while {[string length [set pcheck_file [punkcheck::cli::lib::find_nearest_file $search_from]]]} { + set pcheck_folder [file dirname $pcheck_file] + lappend bottom_to_top $pcheck_file + set search_from [file dirname $pcheck_folder] + } + return $bottom_to_top + } + #todo! - group by fileset + proc status {{path {}}} { + if {$path eq {}} { set path [pwd] } + set fullpath [file normalize $path] + + set ftype [file type $fullpath] + + + set files [list] + if {$ftype eq "file"} { + set container [file dirname $fullpath] + lappend files $fullpath + } else { + set container $fullpath + #vfs can mask mounted files - so we can't just use 'file type' or glob with -type f + ##set files [glob -nocomplain -dir $fullpath -type f *] + package require punk::nav::fs + + #TODO - get all files in tree!!! + set folderinfo [punk::nav::fs::dirfiles_dict $fullpath] + set files [concat [dict get $folderinfo files] [dict get $folderinfo underlayfiles]] + } + set punkcheck_files [paths $container] + set repodict [punk::repo::find_repo $container] + + if {![llength $punkcheck_files]} { + puts stderr "No .punkcheck files found at or above this folder" + } + + set table "" + set files_with_records [list] + foreach p $punkcheck_files { + set basedir [file dirname $p] + set recordlist [punkcheck::load_records_from_file $p] + set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] + + foreach f $files { + set relpath [punkcheck::lib::path_relative $basedir $f] + + if {[dict exists $tgt_dict $relpath]} { + set filerec [dict get $tgt_dict $relpath] + set records [punkcheck::dict_getwithdefault $filerec body [list]] + if {$ftype eq "file"} { + if {![llength $records]} { + set pcheck "(has file record but no installation entries)" + } else { + set pcheck \n + foreach irec $records { + append pcheck [punk::tdl::prettyprint [list $irec] 1] \n + #append pcheck " $irec" \n + } + } + } else { + if {![llength $records]} { + set pcheck "(has file record but no installation entries)" + } else { + set display_records [list] + set pcheck \n + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] + if {[llength $latest_install_record]} { + lappend display_records $latest_install_record + } + if {$latest_install_record ne [lindex $records end]} { + lappend display_records [lindex $records end] + } + foreach irec $display_records { + append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]" + set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]] + set source_files [list] + set source_files_changed [list] + set source_folders [list] + set source_folders_changed [list] + foreach r $bodyrecords { + if {[dict get $r tag] eq "SOURCE"} { + set path [dict get $r -path] + set changed [dict get $r -changed] + switch -- [dict get $r -type] { + file { + lappend source_files $path + if {$changed} { + lappend source_files_changed $path + } + } + directory { + lappend source_folders $path + if {$changed} { + lappend source_folders_changed $path + } + } + } + } + } + if {[llength $source_files]} { + append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" + } + if {[llength $source_folders]} { + append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" + } + append pcheck \n + + #append pcheck [punk::tdl::prettyprint [list $irec] 1] \n + #append pcheck " $irec" \n + } + } + } + append table "$f $pcheck" \n + } + } + } + return $table + } + proc status_by_file {{path {}}} { + if {$path eq {}} { set path [pwd] } + set fullpath [file normalize $path] + set ftype [file type $fullpath] + set files [list] + if {$ftype eq "file"} { + set container [file dirname $fullpath] + lappend files $fullpath + } else { + set container $fullpath + set files [glob -nocomplain -dir $fullpath -type f *] + } + set punkcheck_files [paths $container] + set repodict [punk::repo::find_repo $container] + + if {![llength $punkcheck_files]} { + puts stderr "No .punkcheck files found at or above this folder" + } + + set table "" + set files_with_records [list] + foreach p $punkcheck_files { + set basedir [file dirname $p] + set recordlist [punkcheck::load_records_from_file $p] + set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] + foreach f $files { + set relpath [punkcheck::lib::path_relative $basedir $f] + + if {[dict exists $tgt_dict $relpath]} { + set filerec [dict get $tgt_dict $relpath] + set records [punkcheck::dict_getwithdefault $filerec body [list]] + if {$ftype eq "file"} { + if {![llength $records]} { + set pcheck "(has file record but no installation entries)" + } else { + set pcheck \n + foreach irec $records { + append pcheck [punk::tdl::prettyprint [list $irec] 1] \n + #append pcheck " $irec" \n + } + } + } else { + if {![llength $records]} { + set pcheck "(has file record but no installation entries)" + } else { + set display_records [list] + set pcheck \n + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] + lappend display_records $latest_install_record + if {$latest_install_record ne [lindex $records end]} { + lappend display_records [lindex $records end] + } + foreach irec $display_records { + append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]" + set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]] + set source_files [list] + set source_files_changed [list] + set source_folders [list] + set source_folders_changed [list] + foreach r $bodyrecords { + if {[dict get $r tag] eq "SOURCE"} { + set path [dict get $r -path] + set changed [dict get $r -changed] + switch -- [dict get $r -type] { + file { + lappend source_files $path + if {$changed} { + lappend source_files_changed $path + } + } + directory { + lappend source_folders $path + if {$changed} { + lappend source_folders_changed $path + } + } + } + } + } + if {[llength $source_files]} { + append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" + } + if {[llength $source_folders]} { + append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" + } + append pcheck \n + + #append pcheck [punk::tdl::prettyprint [list $irec] 1] \n + #append pcheck " $irec" \n + } + } + } + append table "$f $pcheck" \n + } + } + } + return $table + } +} + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punkcheck::cli::lib { + namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc + + proc find_nearest_file {{path {}}} { + if {$path eq {}} { set path [pwd] } + set folder [lib::scanup $path lib::is_punkchecked_folder] + if {$folder eq ""} { + return "" + } else { + return [file join $folder .punkcheck] + } + } + + proc is_punkchecked_folder {{path {}}} { + if {$path eq {}} { set path [pwd] } + foreach control { + .punkcheck + } { + set control [file join $path $control] + if {[file isfile $control]} {return 1} + } + return 0 + } + + proc scanup {path cmd} { + if {$path eq {}} { set path [pwd] } + #based on kettle::path::scanup + if {[file pathtype $path] eq "relative"} { + set path [file normalize $path] + } + while {1} { + # Found the proper directory, per the predicate. + if {[{*}$cmd $path]} { return $path } + + # Not found, walk to parent + set new [file dirname $path] + + # Stop when reaching the root. + if {$new eq $path} { return {} } + if {$new eq {}} { return {} } + + # Ok, truly walk up. + set path $new + } + return {} + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punkcheck::cli { + proc _cli {args} { + #don't use tailcall - base uses info level to determine caller + ::punk::mix::base::_cli {*}$args + } + variable default_command status + package require punk::mix::base + package require punk::overlay + punk::overlay::custom_from_base [namespace current] ::punk::mix::base +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punkcheck::cli [namespace eval punkcheck::cli { + variable version + set version 0.1.0 +}] +return + + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm new file mode 100644 index 00000000..d70d657c --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm @@ -0,0 +1,3122 @@ +#copyright 2023 Julian Marcel Noble +#license: BSD (revised 3-clause) +# +#Note shellfilter is currently only directly useful for unidirectional channels e.g stdin,stderr,stdout, or for example fifo2 where only one direction is being used. +#To generalize this to bidrectional channels would require shifting around read & write methods on transform objects in a very complicated manner. +#e.g each transform would probably be a generic transform container which holds sub-objects to which read & write are indirected. +#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway +# - as presumably the reads/writes from a bidirectional channel could be diverted off to unidirectional pipelines for processing with less work +# (and maybe even better speed/efficiency if the data volume is asymmetrical and there is significant processing on one direction) +# + + +tcl::namespace::eval shellfilter::log { + variable allow_adhoc_tags 1 + variable open_logs [tcl::dict::create] + variable is_enabled 0 + + proc disable {} { + variable is_enabled + set is_enabled 0 + proc ::shellfilter::log::open {tag settingsdict} {} + proc ::shellfilter::log::write {tag msg} {} + proc ::shellfilter::log::write_sync {tag msg} {} + proc ::shellfilter::log::close {tag} {} + } + + proc enable {} { + variable is_enabled + set is_enabled 1 + #'tag' is an identifier for the log source. + # each tag will use it's own thread to write to the configured log target + proc ::shellfilter::log::open {tag {settingsdict {}}} { + upvar ::shellfilter::sources sourcelist + if {![dict exists $settingsdict -tag]} { + tcl::dict::set settingsdict -tag $tag + } else { + #review + if {$tag ne [tcl::dict::get $settingsdict -tag]} { + error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" + } + } + if {$tag ni $sourcelist} { + lappend sourcelist $tag + } + + #note new_worker + set worker_tid [shellthread::manager::new_worker $tag $settingsdict] + #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" + return $worker_tid + } + proc ::shellfilter::log::write {tag msg} { + upvar ::shellfilter::sources sourcelist + variable allow_adhoc_tags + if {!$allow_adhoc_tags} { + if {$tag ni $sourcelist} { + error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" + } + } + shellthread::manager::write_log $tag $msg + } + #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written + proc ::shellfilter::log::write_sync {tag msg} { + shellthread::manager::write_log $tag $msg -async 0 + } + proc ::shellfilter::log::close {tag} { + #shellthread::manager::close_worker $tag + shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed + } + + } + + #review + #configure whether we can call shellfilter::log::write without having called open first + proc require_open {{is_open_required {}}} { + variable allow_adhoc_tags + if {![string length $is_open_required]} { + return $allow_adhoc_tags + } else { + set truevalues [list y yes true 1] + set falsevalues [list n no false 0] + if {[string tolower $is_open_required] in $truevalues} { + set allow_adhoc_tags 1 + } elseif {[string tolower $is_open_required] in $falsevalues} { + set allow_adhoc_tags 0 + } else { + error "shellfilter::log::require_open unrecognised value '$is_open_required' try one of $truevalues or $falsevalues" + } + } + } + if {[catch {package require shellthread}]} { + shellfilter::log::disable + } else { + shellfilter::log::enable + } + +} +namespace eval shellfilter::pipe { + #write channel for program. workerthread reads other end of fifo2 and writes data somewhere + proc open_out {tag_pipename {pipesettingsdict {}}} { + set defaultsettings {-buffering full} + set settingsdict [dict merge $defaultsettings $pipesettingsdict] + package require shellthread + #we are only using the fifo in a single direction to pipe to another thread + # - so whilst wchan and rchan could theoretically each be both read & write we're only using them for one operation each + if {![catch {package require Memchan}]} { + lassign [fifo2] wchan rchan + } else { + package require tcl::chan::fifo2 + lassign [tcl::chan::fifo2] wchan rchan + } + #default -translation for both types of fifo on windows is {auto crlf} + # -encoding is as per '[encoding system]' on the platform - e.g utf-8 (e.g windows when beta-utf8 enabled) + chan configure $wchan -buffering [dict get $settingsdict -buffering] ;# + #application end must not be binary for our filters to operate on it + + + #chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably.. + chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf + + set worker_tid [shellthread::manager::new_pipe_worker $tag_pipename $settingsdict] + #puts stderr "worker_tid: $worker_tid" + + #set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer + shellthread::manager::set_pipe_read_from_client $tag_pipename $worker_tid $rchan + + set pipeinfo [list localchan $wchan remotechan $rchan workertid $worker_tid direction out] + return $pipeinfo + } + + #read channel for program. workerthread writes to other end of fifo2 from whereever it's reading (stdin, file?) + proc open_in {tag_pipename {settingsdict {} }} { + package require shellthread + package require tcl::chan::fifo2 + lassign [tcl::chan::fifo2] wchan rchan + set program_chan $rchan + set worker_chan $wchan + chan configure $worker_chan -buffering [dict get $settingsdict -buffering] + chan configure $program_chan -buffering [dict get $settingsdict -buffering] + + chan configure $program_chan -blocking 0 + chan configure $worker_chan -blocking 0 + set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] + + shellthread::manager::set_pipe_write_to_client $tag_pipename $worker_tid $worker_chan + + set pipeinfo [list localchan $program_chan remotechan $worker_chan workertid $worker_tid direction in] + puts stderr "|jn>pipe::open_in returning $pipeinfo" + puts stderr "program_chan: [chan conf $program_chan]" + return $pipeinfo + } + +} + + + +namespace eval shellfilter::ansi { + #maint warning - + #ansistrip from punk::ansi is better/more comprehensive + proc stripcodes {text} { + #obsolete? + #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). + dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] + #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic + dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals + #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. + #line endings can theoretically occur within an ansi escape sequence (review e.g title?) + set inputlist [split $text ""] + set outputlist [list] + + #self-contained 2 byte ansi escape sequences - review more? + set 2bytecodes_dict [dict create\ + "reset_terminal" "\033c"\ + "save_cursor_posn" "\u001b7"\ + "restore_cursor_posn" "\u001b8"\ + "cursor_up_one" "\u001bM"\ + ] + set 2bytecodes [dict values $2bytecodes_dict] + + set in_escapesequence 0 + #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls + set i 0 + foreach u $inputlist { + set v [lindex $inputlist $i+1] + set uv ${u}${v} + if {$in_escapesequence eq "2b"} { + #2nd byte - done. + set in_escapesequence 0 + } elseif {$in_escapesequence != 0} { + set escseq [dict get $escape_terminals $in_escapesequence] + if {$u in $escseq} { + set in_escapesequence 0 + } elseif {$uv in $escseq} { + set in_escapseequence 2b ;#flag next byte as last in sequence + } + } else { + #handle both 7-bit and 8-bit CSI and OSC + if {[regexp {^(?:\033\[|\u009b)} $uv]} { + set in_escapesequence CSI + } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { + set in_escapesequence OSC + } elseif {$uv in $2bytecodes} { + #self-contained e.g terminal reset - don't pass through. + set in_escapesequence 2b + } else { + lappend outputlist $u + } + } + incr i + } + return [join $outputlist ""] + } + +} +namespace eval shellfilter::chan { + set testobj ::shellfilter::chan::var + if {$testobj ni [info commands $testobj]} { + + oo::class create var { + variable o_datavar + variable o_trecord + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + set varname [dict get $settingsdict -varname] + set o_datavar $varname + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 1 ;# as a var is diversionary - default it to be a jucntion + } + } + method initialize {ch mode} { + return [list initialize finalize write] + } + method finalize {ch} { + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {ch count} { + # return ? + #} + method write {ch bytes} { + set stringdata [encoding convertfrom $o_enc $bytes] + append $o_datavar $stringdata + return "" + } + method meta_is_redirection {} { + return $o_is_junction + } + method meta_buffering_supported {} { + return [list line full none] + } + } + + #todo - something similar for multiple grep specs each with own -pre & -post .. store to dict? + oo::class create tee_grep_to_var { + variable o_datavar + variable o_lastxlines + variable o_trecord + variable o_grepfor + variable o_prelines + variable o_postlines + variable o_postcountdown + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set o_lastxlines [list] + set o_postcountdown 0 + set defaults [tcl::dict::create -pre 1 -post 1] + set settingsdict [tcl::dict::get $tf -settings] + set settings [tcl::dict::merge $defaults $settingsdict] + set o_datavar [tcl::dict::get $settings -varname] + set o_grepfor [tcl::dict::get $settings -grep] + set o_prelines [tcl::dict::get $settings -pre] + set o_postlines [tcl::dict::get $settings -post] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize finalize write] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #method read {transform_handle count} { + # return ? + #} + method write {transform_handle bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + set lastx $o_lastxlines + lappend o_lastxlines $logdata + + if {$o_postcountdown > 0} { + append $o_datavar $logdata + if {[regexp $o_grepfor $logdata]} { + #another match in postlines + set o_postcountdown $o_postlines + } else { + incr o_postcountdown -1 + } + } else { + if {[regexp $o_grepfor $logdata]} { + append $o_datavar [join $lastx] + append $o_datavar $logdata + set o_postcountdown $o_postlines + } + } + + if {[llength $o_lastxlines] > $o_prelines} { + set o_lastxlines [lrange $o_lastxlines 1 end] + } + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + method meta_buffering_supported {} { + return [list line] + } + } + + oo::class create tee_to_var { + variable o_datavars + variable o_trecord + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set settingsdict [tcl::dict::get $tf -settings] + set varname [tcl::dict::get $settingsdict -varname] + set o_datavars $varname + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {ch mode} { + return [list initialize finalize write flush clear] + } + method finalize {ch} { + my destroy + } + method clear {ch} { + return + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {ch count} { + # return ? + #} + method flush {ch} { + return "" + } + method write {ch bytes} { + set stringdata [tcl::encoding::convertfrom $o_enc $bytes] + foreach v $o_datavars { + append $v $stringdata + } + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + } + oo::class create tee_to_pipe { + variable o_logsource + variable o_localchan + variable o_enc + variable o_trecord + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set settingsdict [tcl::dict::get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "tee_to_pipe constructor settingsdict missing -tag" + } + set o_localchan [tcl::dict::get $settingsdict -pipechan] + set o_logsource [tcl::dict::get $settingsdict -tag] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize read drain write flush clear finalize] + } + method finalize {transform_handle} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {transform_handle events} { + # must be present but we ignore it because we do not + # post any events + } + method clear {transform_handle} { + return + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + #::shellfilter::log::write $o_logsource $logdata + puts -nonewline $o_localchan $logdata + return $bytes + } + method flush {transform_handle} { + return "" + } + method write {transform_handle bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + #::shellfilter::log::write $o_logsource $logdata + puts -nonewline $o_localchan $logdata + return $bytes + } + #a tee is not a redirection - because data still flows along the main path + method meta_is_redirection {} { + return $o_is_junction + } + + } + oo::class create tee_to_log { + variable o_tid + variable o_logsource + variable o_trecord + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set settingsdict [tcl::dict::get $tf -settings] + if {![tcl::dict::exists $settingsdict -tag]} { + error "tee_to_log constructor settingsdict missing -tag" + } + set o_logsource [tcl::dict::get $settingsdict -tag] + set o_tid [::shellfilter::log::open $o_logsource $settingsdict] + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {ch mode} { + return [list initialize read write finalize] + } + method finalize {ch} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + method read {ch bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + ::shellfilter::log::write $o_logsource $logdata + return $bytes + } + method write {ch bytes} { + set logdata [tcl::encoding::convertfrom $o_enc $bytes] + ::shellfilter::log::write $o_logsource $logdata + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + + oo::class create logonly { + variable o_tid + variable o_logsource + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "logonly constructor settingsdict missing -tag" + } + set o_logsource [dict get $settingsdict -tag] + set o_tid [::shellfilter::log::open $o_logsource $settingsdict] + } + method initialize {transform_handle mode} { + return [list initialize finalize write] + } + method finalize {transform_handle} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {transform_handle events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {transform_handle count} { + # return ? + #} + method write {transform_handle bytes} { + set logdata [encoding convertfrom $o_enc $bytes] + if 0 { + if {"utf-16le" in [encoding names]} { + set logdata [encoding convertfrom utf-16le $bytes] + } else { + set logdata [encoding convertto utf-8 $bytes] + #set logdata [encoding convertfrom unicode $bytes] + #set logdata $bytes + } + } + #set logdata $bytes + #set logdata [string map [list \r -r- \n -n-] $logdata] + #if {[string equal [string range $logdata end-1 end] "\r\n"]} { + # set logdata [string range $logdata 0 end-2] + #} + #::shellfilter::log::write_sync $o_logsource $logdata + ::shellfilter::log::write $o_logsource $logdata + #return $bytes + return + } + method meta_is_redirection {} { + return 1 + } + } + + #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) + # - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?) + #punk::ansi::ansistrip converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion + #assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations! + oo::class create ansistrip { + variable o_trecord + variable o_enc + variable o_is_junction + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [dict get $tf -encoding] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize read write clear flush drain finalize] + } + method finalize {transform_handle} { + my destroy + } + method clear {transform_handle} { + return + } + method watch {transform_handle events} { + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + set outstring [punk::ansi::ansistrip $instring] + return [encoding convertto $o_enc $outstring] + } + method flush {transform_handle} { + return "" + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + set outstring [punk::ansi::ansistrip $instring] + return [encoding convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + #a test + oo::class create reconvert { + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + } + oo::define reconvert { + method meta_is_redirection {} { + return 0 + } + } + + + #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it. + #It can be useful for test/debugging + #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi + # + set sixelstart_re {\x1bP([;0-9]*)q} ;#7-bit - todo 8bit + #todo kitty graphics \x1b_G... + #todo iterm graphics + + oo::class create ansiwrap { + variable o_trecord + variable o_enc + variable o_colour + variable o_do_colour + variable o_do_normal + variable o_is_junction + variable o_codestack + variable o_gx_state ;#on/off alt graphics + variable o_buffered + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [tcl::dict::get $tf -encoding] + set settingsdict [tcl::dict::get $tf -settings] + if {[tcl::dict::exists $settingsdict -colour]} { + set o_colour [tcl::dict::get $settingsdict -colour] + set o_do_colour [punk::ansi::a+ {*}$o_colour] + set o_do_normal [punk::ansi::a] + } else { + set o_colour {} + set o_do_colour "" + set o_do_normal "" + } + set o_codestack [list] + set o_gx_state [expr {off}] + set o_buffered "" ;#hold back data that potentially contains partial ansi codes + if {[tcl::dict::exists $tf -junction]} { + set o_is_junction [tcl::dict::get $tf -junction] + } else { + set o_is_junction 0 + } + } + + + #todo - track when in sixel,iterm,kitty graphics data - can be very large + method Trackcodes {chunk} { + #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" + set buf $o_buffered$chunk + set emit "" + if {[string last \x1b $buf] >= 0} { + #detect will detect ansi SGR and gron groff and other codes + if {[punk::ansi::ta::detect $buf]} { + #split_codes_single regex faster than split_codes - but more resulting parts + #'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc) + set parts [punk::ansi::ta::split_codes_single $buf] + #process all pt/code pairs except for trailing pt + foreach {pt code} [lrange $parts 0 end-1] { + #puts "<==[ansistring VIEW -lf 1 $pt]==>" + if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + append emit $o_do_colour$pt$o_do_normal + #append emit $pt + } else { + append emit $pt + } + + 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 o_codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #todo - make caching is_sgr method + set dup_posns [lsearch -all -exact $o_codestack $code] + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + } else { + + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set o_gx_state on + } + "B" { + set o_gx_state off + } + } + } + default { + #other ansi codes + } + } + append emit $code + } + + + set trailing_pt [lindex $parts end] + if {[string first \x1b $trailing_pt] >= 0} { + #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" + #may not be plaintext after all + set o_buffered $trailing_pt + #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" + } else { + #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] + if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { + append emit $o_do_colour$trailing_pt$o_do_normal + } else { + append emit $trailing_pt + } + #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext + set o_buffered "" + } + + + } else { + #REVIEW - this holding a buffer without emitting as we go is ugly. + # - we may do better to detect and retain the opener, then use that opener to avoid false splits within the sequence. + # - we'd then need to detect the appropriate close to restart splitting and codestacking + # - we may still need to retain and append the data to the opener (in some cases?) - which is a slight memory issue - but at least we would emit everything immediately. + + + #puts "-->esc but no detect" + #no complete ansi codes - but at least one esc is present + if {[string last \x1b $buf] == [llength $buf]-1} { + #only esc is last char in buf + #puts ">>trailing-esc<<" + set o_buffered \x1b + set emit [string range $buf 0 end-1] + } else { + set emit_anyway 0 + #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer + if {[punk::ansi::ta::detect_st_open $buf]} { + #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) + set st_partial_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code + #todo - configurable ST max - use 1k for now + if {$st_partial_len < 1001} { + append o_buffered $chunk + set emit "" + } else { + set emit_anyway 1 + } + } else { + set possible_code_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of possible code + #most opening sequences are 1,2 or 3 chars - review? + set open_sequence_detected [punk::ansi::ta::detect_open $buf] + if {$possible_code_len > 10 && !$open_sequence_detected} { + set emit_anyway 1 + } else { + #could be composite sequence with params - allow some reasonable max sequence length + #todo - configurable max sequence length + #len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies + # - allow some headroom for redundant codes when the caller didn't merge. + if {$possible_code_len < 101} { + append o_buffered $chunk + set emit "" + } else { + #allow a little more grace if we at least have an opening ansi sequence of any type.. + if {$open_sequence_detected && $possible_code_len < 151} { + append o_buffered $chunk + set emit "" + } else { + set emit_anyway 1 + } + } + } + } + if {$emit_anyway} { + #looked ansi-like - but we've given enough length without detecting close.. + #treat as possible plain text with some esc or unrecognised ansi sequence + if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + set emit $o_do_colour$buf$o_do_normal + } else { + set emit $buf + } + } + } + } + } else { + #no esc + #puts stdout [a+ yellow]...[a] + #test! + if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + set emit $o_do_colour$buf$o_do_normal + } else { + set emit $buf + } + #set emit $buf + set o_buffered "" + } + return [dict create emit $emit stacksize [llength $o_codestack]] + } + method initialize {transform_handle mode} { + #clear undesirable in terminal output channels (review) + return [list initialize write flush read drain finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method clear {transform_handle} { + #In the context of stderr/stdout - we probably don't want clear to run. + #Terminals might call it in the middle of a split ansi code - resulting in broken output. + #Leave clear of it the init call + puts stdout "" + set emit [tcl::encoding::convertto $o_enc $o_buffered] + set o_buffered "" + return $emit + } + method flush {transform_handle} { + #puts stdout "" + set emit [tcl::encoding::convertto $o_enc $o_buffered] + set o_buffered "" + return $emit + return + } + method write {transform_handle bytes} { + set instring [tcl::encoding::convertfrom $o_enc $bytes] + set streaminfo [my Trackcodes $instring] + set emit [dict get $streaminfo emit] + if {[dict get $streaminfo stacksize] == 0} { + #no ansi on the stack - we can wrap + #review + set outstring "$o_do_colour$emit$o_do_normal" + } else { + set outstring $emit + } + #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" + #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" + return [tcl::encoding::convertto $o_enc $outstring] + } + method Write_naive {transform_handle bytes} { + set instring [tcl::encoding::convertfrom $o_enc $bytes] + set outstring "$o_do_colour$instring$o_do_normal" + #set outstring ">>>$instring" + return [tcl::encoding::convertto $o_enc $outstring] + } + method drain {transform_handle} { + return "" + } + method read {transform_handle bytes} { + set instring [tcl::encoding::convertfrom $o_enc $bytes] + set outstring "$o_do_colour$instring$o_do_normal" + return [tcl::encoding::convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + #todo - something + oo::class create rebuffer { + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + #set outstring [string map [list \n ] $instring] + set outstring $instring + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define rebuffer { + method meta_is_redirection {} { + return 0 + } + } + + #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence + oo::class create tounix { + variable o_trecord + variable o_enc + variable o_last_char_was_cr + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + set o_last_char_was_cr 0 + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #don't use read + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + #set outstring [string map [list \n ] $instring] + + if {$o_last_char_was_cr} { + set instring "\r$instring" + } + + set outstring [string map {\r\n \n} $instring] + set lastchar [string range $outstring end end] + if {$lastchar eq "\r"} { + set o_last_char_was_cr 1 + set outstring [string range $outstring 0 end-1] + } else { + set o_last_char_was_cr 0 + } + #review! can we detect eof here on the transform_handle? + #if eof, we don't want to strip a trailing \r + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define tounix { + method meta_is_redirection {} { + return $o_is_junction + } + } + #write to handle case where line-endings already \r\n too + oo::class create towindows { + variable o_trecord + variable o_enc + variable o_last_char_was_cr + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + set o_last_char_was_cr 0 + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #don't use read + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + #set outstring [string map [list \n ] $instring] + + if {$o_last_char_was_cr} { + set instring "\r$instring" + } + + set outstring [string map {\r\n \uFFFF} $instring] + set outstring [string map {\n \r\n} $outstring] + set outstring [string map {\uFFFF \r\n} $outstring] + + set lastchar [string range $outstring end end] + if {$lastchar eq "\r"} { + set o_last_char_was_cr 1 + set outstring [string range $outstring 0 end-1] + } else { + set o_last_char_was_cr 0 + } + #review! can we detect eof here on the transform_handle? + #if eof, we don't want to strip a trailing \r + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define towindows { + method meta_is_redirection {} { + return $o_is_junction + } + } + + } +} + +# ---------------------------------------------------------------------------- +#review float/sink metaphor. +#perhaps something with the concept of upstream and downstream? +#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. +## upstream for stdin is at the bottom of the stack and for stdout is the top of the stack. +#upstream,neutral-upstream,downstream,downstream-aside,downstream-replace (default neutral-upstream - require action 'stack' to use standard channel stacking concept and ignore other actions) +#This is is a bit different from the float/sink metaphor which refers to the channel stacking order as opposed to the data-flow direction. +#The idea would be that whether input or output +# upstream additions go to the side closest to the datasource +# downstream additions go furthest from the datasource +# - all new additions go ahead of any diversions as the most upstream diversion is the current end of the stream in a way. +# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. +# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) +# neutral-upstream goes to the datasource side of the neutral-upstream list. +# No 'neutral' option provided so that we avoid the need to think forwards or backwards when adding stdin vs stdout shellfilter does the necessary pop/push reordering. +# No 'neutral-downstream' to reduce complexity. +# downstream-replace & downstream-aside head downstream to the first diversion they encounter. ie these actions are no longer referring to the stack direction but only the dataflow direction. +# +# ---------------------------------------------------------------------------- +# +# 'filters' are transforms that don't redirect +# - limited range of actions to reduce complexity. +# - any requirement not fulfilled by float,sink,sink-replace,sink-sideline should be done by multiple pops and pushes +# +#actions can float to top of filters or sink to bottom of filters +#when action is of type sink, it can optionally replace or sideline the first non-filter it encounters (highest redirection on the stack.. any lower are starved of the stream anyway) +# - sideline means to temporarily replace the item and keep a record, restoring if/when we are removed from the transform stack +# +##when action is of type float it can't replace or sideline anything. A float is added above any existing floats and they stay in the same order relative to each other, +#but non-floats added later will sit below all floats. +#(review - float/sink initially designed around output channels. For stdin the dataflow is reversed. implement float-aside etc?) +# +# +#action: float sink sink-replace,sink-sideline +# +# +## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept. +## +namespace eval shellfilter::stack { + namespace export {[a-z]*} + namespace ensemble create + #todo - implement as oo ? + variable pipelines [list] + + proc items {} { + #review - stdin,stdout,stderr act as pre-existing pipelines, and we can't create a new one with these names - so they should probably be autoconfigured and listed.. + # - but in what contexts? only when we find them in [chan names]? + variable pipelines + return [dict keys $pipelines] + } + proc item {pipename} { + variable pipelines + return [dict get $pipelines $pipename] + } + proc item_tophandle {pipename} { + variable pipelines + set handle "" + if {[dict exists $pipelines $pipename stack]} { + set stack [dict get $pipelines $pipename stack] + set topstack [lindex $stack end] ;#last item in stack is top (for output channels anyway) review comment. input chans? + if {$topstack ne ""} { + if {[dict exists $topstack -handle]} { + set handle [dict get $topstack -handle] + } + } + } + return $handle + } + proc status {{pipename *} args} { + variable pipelines + set pipecount [dict size $pipelines] + set tabletitle "$pipecount pipelines active" + set t [textblock::class::table new $tabletitle] + $t add_column -headers [list channel-ident] + $t add_column -headers [list device-info localchan] + $t configure_column 1 -header_colspans {3} + $t add_column -headers [list "" remotechan] + $t add_column -headers [list "" tid] + $t add_column -headers [list stack-info] + foreach k [dict keys $pipelines $pipename] { + set lc [dict get $pipelines $k device localchan] + set rc [dict get $pipelines $k device remotechan] + if {[dict exists $k device workertid]} { + set tid [dict get $pipelines $k device workertid] + } else { + set tid "-" + } + set stack [dict get $pipelines $k stack] + if {![llength $stack]} { + set stackinfo "" + } else { + set tbl_inner [textblock::class::table new] + $tbl_inner configure -show_edge 0 + foreach rec $stack { + set handle [punk::lib::dict_getdef $rec -handle ""] + set id [punk::lib::dict_getdef $rec -id ""] + set transform [namespace tail [punk::lib::dict_getdef $rec -transform ""]] + set settings [punk::lib::dict_getdef $rec -settings ""] + $tbl_inner add_row [list $id $transform $handle $settings] + } + set stackinfo [$tbl_inner print] + $tbl_inner destroy + } + $t add_row [list $k $lc $rc $tid $stackinfo] + } + set result [$t print] + $t destroy + return $result + } + proc status1 {{pipename *} args} { + variable pipelines + + set pipecount [dict size $pipelines] + set tableprefix "$pipecount pipelines active\n" + foreach p [dict keys $pipelines] { + append tableprefix " " $p \n + } + package require overtype + #todo -verbose + set table "" + set ac1 [string repeat " " 15] + set ac2 [string repeat " " 42] + set ac3 [string repeat " " 70] + append table "[overtype::left $ac1 channel-ident] " + append table "[overtype::left $ac2 device-info] " + append table "[overtype::left $ac3 stack-info]" + append table \n + + + set bc1 [string repeat " " 5] ;#stack id + set bc2 [string repeat " " 25] ;#transform + set bc3 [string repeat " " 50] ;#settings + + foreach k [dict keys $pipelines $pipename] { + set lc [dict get $pipelines $k device localchan] + if {[dict exists $k device workertid]} { + set tid [dict get $pipelines $k device workertid] + } else { + set tid "" + } + + + set col1 [overtype::left $ac1 $k] + set col2 [overtype::left $ac2 "localchan: $lc tid:$tid"] + + set stack [dict get $pipelines $k stack] + if {![llength $stack]} { + set col3 $ac3 + } else { + set rec [lindex $stack 0] + set bcol1 [overtype::left $bc1 [dict get $rec -id]] + set bcol2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] + set bcol3 [overtype::left $bc3 [dict get $rec -settings]] + set stackrow "$bcol1 $bcol2 $bcol3" + set col3 [overtype::left $ac3 $stackrow] + } + + append table "$col1 $col2 $col3\n" + + + foreach rec [lrange $stack 1 end] { + set col1 $ac1 + set col2 $ac2 + if {[llength $rec]} { + set bc1 [overtype::left $bc1 [dict get $rec -id]] + set bc2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] + set bc3 [overtype::left $bc3 [dict get $rec -settings]] + set stackrow "$bc1 $bc2 $bc3" + set col3 [overtype::left $ac3 $stackrow] + } else { + set col3 $ac3 + } + append table "$col1 $col2 $col3\n" + } + + } + return $tableprefix$table + } + #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir + proc _get_stack_floaters {stack} { + set floaters [list] + foreach t [lreverse $stack] { + switch -- [dict get $t -action] { + float { + lappend floaters $t + } + default { + break + } + } + } + return [lreverse $floaters] + } + + + + #for output-channel sinking + proc _get_stack_top_redirection {stack} { + set r 0 ;#reverse index + foreach t [lreverse $stack] { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index + return [list index $idx record $t] + } + incr r + } + #not found + return [list index -1 record {}] + } + #exclude float-locked, locked, sink-locked + proc _get_stack_top_redirection_replaceable {stack} { + set r 0 ;#reverse index + foreach t [lreverse $stack] { + set action [dict get $t -action] + if {![string match "*locked*" $action]} { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index + return [list index $idx record $t] + } + } + incr r + } + #not found + return [list index -1 record {}] + } + + + #for input-channels ? + proc _get_stack_bottom_redirection {stack} { + set i 0 + foreach t $stack { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + return [linst index $i record $t] + } + incr i + } + #not found + return [list index -1 record {}] + } + + + proc get_next_counter {pipename} { + variable pipelines + #use dictn incr ? + set counter [dict get $pipelines $pipename counter] + incr counter + dict set pipelines $pipename counter $counter + return $counter + } + + proc unwind {pipename} { + variable pipelines + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $pipelines $pipename device localchan] + foreach tf [lreverse $stack] { + chan pop $localchan + } + dict set pipelines $pipename [list] + } + #todo + proc delete {pipename {wait 0}} { + variable pipelines + set pipeinfo [dict get $pipelines $pipename] + set deviceinfo [dict get $pipeinfo device] + set localchan [dict get $deviceinfo localchan] + unwind $pipename + + #release associated thread + set tid [dict get $deviceinfo workertid] + if {$wait} { + thread::release -wait $tid + } else { + thread::release $tid + } + + #Memchan closes without error - tcl::chan::fifo2 raises something like 'can not find channel named "rc977"' - REVIEW. why? + catch {chan close $localchan} + } + #review - proc name clarity is questionable. remove_stackitem? + proc remove {pipename remove_id} { + variable pipelines + if {![dict exists $pipelines $pipename]} { + puts stderr "WARNING: shellfilter::stack::remove pipename '$pipename' not found in pipelines dict: '$pipelines' [info level -1]" + return + } + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $pipelines $pipename device localchan] + set posn 0 + set idposn -1 + set asideposn -1 + foreach t $stack { + set id [dict get $t -id] + if {$id eq $remove_id} { + set idposn $posn + break + } + #look into asides (only can be one for now) + if {[llength [dict get $t -aside]]} { + set a [dict get $t -aside] + if {[dict get $a -id] eq $remove_id} { + set asideposn $posn + break + } + } + incr posn + } + + if {$asideposn > 0} { + #id wasn't found directly in stack, but in an -aside. we don't need to pop anything - just clear this aside record + set container [lindex $stack $asideposn] + dict set container -aside {} + lset stack $asideposn $container + dict set pipelines $pipename stack $stack + } else { + if {$idposn < 0} { + ::shellfilter::log::write shellfilter "ERROR shellfilter::stack::remove $pipename id '$remove_id' not found" + puts stderr "|WARNING>shellfilter::stack::remove $pipename id '$remove_id' not found" + return 0 + } + set removed_item [lindex $stack $idposn] + + #include idposn in poplist + set poplist [lrange $stack $idposn end] + set stack [lreplace $stack $idposn end] + #pop all chans before adding anything back in! + foreach p $poplist { + chan pop $localchan + } + + if {[llength [dict get $removed_item -aside]]} { + set restore [dict get $removed_item -aside] + set t [dict get $restore -transform] + set tsettings [dict get $restore -settings] + set obj [$t new $restore] + set h [chan push $localchan $obj] + dict set restore -handle $h + dict set restore -obj $obj + lappend stack $restore + } + + #put popped back except for the first one, which we want to remove + foreach p [lrange $poplist 1 end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + dict set p -handle $h + dict set p -obj $obj + lappend stack $p + } + dict set pipelines $pipename stack $stack + } + #JMNJMN 2025 review! + #show_pipeline $pipename -note "after_remove $remove_id" + return 1 + } + + #pop a number of items of the top of the stack, add our transform record, and add back all (or the tail of poplist if pushstartindex > 0) + proc insert_transform {pipename stack transformrecord poplist {pushstartindex 0}} { + variable pipelines + set bottom_pop_posn [expr {[llength $stack] - [llength $poplist]}] + set poplist [lrange $stack $bottom_pop_posn end] + set stack [lreplace $stack $bottom_pop_posn end] + + set localchan [dict get $pipelines $pipename device localchan] + foreach p [lreverse $poplist] { + chan pop $localchan + } + set transformname [dict get $transformrecord -transform] + set transformsettings [dict get $transformrecord -settings] + set obj [$transformname new $transformrecord] + set h [chan push $localchan $obj] + dict set transformrecord -handle $h + dict set transformrecord -obj $obj + dict set transformrecord -note "insert_transform" + lappend stack $transformrecord + foreach p [lrange $poplist $pushstartindex end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + #retain previous -id - code that added it may have kept reference and not expecting it to change + dict set p -handle $h + dict set p -obj $obj + dict set p -note "re-added" + + lappend stack $p + } + return $stack + } + + #fifo2 + proc new {pipename args} { + variable pipelines + if {($pipename in [dict keys $pipelines]) || ($pipename in [chan names])} { + error "shellfilter::stack::new error: pipename '$pipename' already exists" + } + + set opts [dict merge {-settings {}} $args] + set defaultsettings [dict create -raw 1 -buffering line -direction out] + set targetsettings [dict merge $defaultsettings [dict get $opts -settings]] + + set direction [dict get $targetsettings -direction] + + #pipename is the source/facility-name ? + if {$direction eq "out"} { + set pipeinfo [shellfilter::pipe::open_out $pipename $targetsettings] + } else { + puts stderr "|jn> pipe::open_in $pipename $targetsettings" + set pipeinfo [shellfilter::pipe::open_in $pipename $targetsettings] + } + #open_out/open_in will configure buffering based on targetsettings + + set program_chan [dict get $pipeinfo localchan] + set worker_chan [dict get $pipeinfo remotechan] + set workertid [dict get $pipeinfo workertid] + + + set deviceinfo [dict create pipename $pipename localchan $program_chan remotechan $worker_chan workertid $workertid direction $direction] + dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] + + return $deviceinfo + } + #we 'add' rather than 'push' because transforms can float,sink and replace/sideline so they don't necessarily go to the top of the transform stack + proc add {pipename transformname args} { + variable pipelines + #chan names doesn't reflect available channels when transforms are in place + #e.g stdout may exist but show as something like file191f5b0dd80 + if {($pipename ni [dict keys $pipelines])} { + if {[catch {eof $pipename} is_eof]} { + error "shellfilter::stack::add no existing chan or pipename matching '$pipename' in channels:[chan names] or pipelines:$pipelines use stdin/stderr/stdout or shellfilter::stack::new " + } + } + set args [dict merge {-action "" -settings {}} $args] + set action [dict get $args -action] + set transformsettings [dict get $args -settings] + if {[string first "::" $transformname] < 0} { + set transformname ::shellfilter::chan::$transformname + } + if {![llength [info commands $transformname]]} { + error "shellfilter::stack::push unknown transform '$transformname'" + } + + + if {![dict exists $pipelines $pipename]} { + #pipename must be in chan names - existing device/chan + #record a -read and -write end even if the device is only being used as one or the other + set deviceinfo [dict create pipename $pipename localchan $pipename remotechan {}] + dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] + } else { + set deviceinfo [dict get $pipelines $pipename device] + } + + set id [get_next_counter $pipename] + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $deviceinfo localchan] + + #we redundantly store chan in each transform - makes debugging clearer + # -encoding similarly could be stored only at the pipeline level (or even queried directly each filter-read/write), + # but here it may help detect unexpected changes during lifetime of the stack and avoids the chance of callers incorrectly using the transform handle?) + # jn + set transform_record [list -id $id -chan $pipename -encoding [chan configure $localchan -encoding] -transform $transformname -aside {} {*}$args] + switch -glob -- $action { + float - float-locked { + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + lappend stack $transform_record + } + "" - locked { + set floaters [_get_stack_floaters $stack] + if {![llength $floaters]} { + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + lappend stack $transform_record + } else { + set poplist $floaters + set stack [insert_transform $pipename $stack $transform_record $poplist] + } + } + "sink*" { + set redirinfo [_get_stack_top_redirection $stack] + set idx_existing_redir [dict get $redirinfo index] + if {$idx_existing_redir == -1} { + #no existing redirection transform on the stack + #pop everything.. add this record as the first redirection on the stack + set poplist $stack + set stack [insert_transform $pipename $stack $transform_record $poplist] + } else { + switch -glob -- $action { + "sink-replace" { + #include that index in the poplist + set poplist [lrange $stack $idx_existing_redir end] + #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end' + set stack [insert_transform $pipename $stack $transform_record $poplist 1] + } + "sink-aside*" { + set existing_redir_record [lindex $stack $idx_existing_redir] + if {[string match "*locked*" [dict get $existing_redir_record -action]]} { + set put_aside 0 + #we can't aside this one - sit above it instead. + set poplist [lrange $stack $idx_existing_redir+1 end] + set stack [lrange $stack 0 $idx_existing_redir] + } else { + set put_aside 1 + dict set transform_record -aside [lindex $stack $idx_existing_redir] + set poplist [lrange $stack $idx_existing_redir end] + set stack [lrange $stack 0 $idx_existing_redir-1] + } + foreach p $poplist { + chan pop $localchan + } + set transformname [dict get $transform_record -transform] + set transform_settings [dict get $transform_record -settings] + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + dict set transform_record -note "insert_transform-with-aside" + lappend stack $transform_record + #add back poplist *except* the one we transferred into -aside (if we were able) + foreach p [lrange $poplist $put_aside end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + #retain previous -id - code that added it may have kept reference and not expecting it to change + dict set p -handle $h + dict set p -obj $obj + dict set p -note "re-added-after-sink-aside" + lappend stack $p + } + } + default { + #plain "sink" + #we only sink to the topmost redirecting filter - which makes sense for an output channel + #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection. + #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there. + # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive. + # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour + set poplist [lrange $stack $idx_existing_redir+1 end] + set stack [insert_transform $pipename $stack $transform_record $poplist] + } + } + } + } + default { + error "shellfilter::stack::add unimplemented action '$action'" + } + } + + dict set pipelines $pipename stack $stack + #puts stdout "==" + #puts stdout "==>stack: $stack" + #puts stdout "==" + + #JMNJMN + #show_pipeline $pipename -note "after_add $transformname $args" + return $id + } + proc show_pipeline {pipename args} { + variable pipelines + set stack [dict get $pipelines $pipename stack] + set tag "SHELLFILTER::STACK" + #JMN - load from config + #::shellfilter::log::open $tag {-syslog 127.0.0.1:514} + if {[catch { + ::shellfilter::log::open $tag {-syslog ""} + } err]} { + #e.g safebase interp can't load required modules such as shellthread (or Thread) + puts stderr "shellfilter::show_pipeline cannot open log" + return + } + ::shellfilter::log::write $tag "transform stack for $pipename $args" + foreach tf $stack { + ::shellfilter::log::write $tag " $tf" + } + + } +} + + +namespace eval shellfilter { + variable sources [list] + variable stacks [dict create] + + proc ::shellfilter::redir_channel_to_log {chan args} { + variable sources + set default_logsettings [dict create \ + -tag redirected_$chan -syslog "" -file ""\ + ] + if {[dict exists $args -action]} { + set action [dict get $args -action] + } else { + # action "sink" is a somewhat reasonable default for an output redirection transform + # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack + # also.. for stdin transform sink makes less sense.. + #todo - default "stack" instead of empty string + set action "" + } + if {[dict exists $args -settings]} { + set logsettings [dict get $args -settings] + } else { + set logsettings {} + } + + set logsettings [dict merge $default_logsettings $logsettings] + set tag [dict get $logsettings -tag] + if {$tag ni $sources} { + lappend sources $tag + } + + set id [shellfilter::stack::add $chan logonly -action $action -settings $logsettings] + return $id + } + + proc ::shellfilter::redir_output_to_log {tagprefix args} { + variable sources + + set default_settings [list -tag ${tagprefix} -syslog "" -file ""] + + set opts [dict create -action "" -settings {}] + set opts [dict merge $opts $args] + set optsettings [dict get $opts -settings] + set settings [dict merge $default_settings $optsettings] + + set tag [dict get $settings -tag] + if {$tag ne $tagprefix} { + error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" + } + lappend sources ${tagprefix}stdout ${tagprefix}stderr + + set stdoutsettings $settings + dict set stdoutsettings -tag ${tagprefix}stdout + set stderrsettings $settings + dict set stderrsettings -tag ${tagprefix}stderr + + set idout [redir_channel_to_log stdout -action [dict get $opts -action] -settings $stdoutsettings] + set iderr [redir_channel_to_log stderr -action [dict get $opts -action] -settings $stderrsettings] + + return [list $idout $iderr] + } + + #eg try: set v [list #a b c] + #vs set v {#a b c} + proc list_is_canonical l { + #courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl + if {[catch {llength $l}]} {return 0} + string equal $l [list {*}$l] + } + + #return a dict keyed on numerical list index showing info about each element + # - particularly + # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list + # 'head_tail_chars' to show current first and last character (in case it's wrapped e.g in double or single quotes or an existing set of braces) + proc list_element_info {inputlist} { + set i 0 + set info [dict create] + set testlist [list] + foreach original_item $inputlist { + #--- + # avoid sharing internal rep with original items in the list (avoids shimmering of rep in original list for certain items such as paths) + unset -nocomplain item + append item $original_item {} + #--- + + set iteminfo [dict create] + set itemlen [string length $item] + lappend testlist $item + set tcl_len [string length $testlist] + set diff [expr {$tcl_len - $itemlen}] + if {$diff == 0} { + dict set iteminfo wouldbrace 0 + dict set iteminfo wouldescape 0 + } else { + #test for escaping vs bracing! + set testlistchars [split $testlist ""] + if {([lindex $testlistchars 0] eq "\{") && ([lindex $testlistchars end] eq "\}")} { + dict set iteminfo wouldbrace 1 + dict set iteminfo wouldescape 0 + } else { + dict set iteminfo wouldbrace 0 + dict set iteminfo wouldescape 1 + } + } + set testlist [list] + set charlist [split $item ""] + set char_a [lindex $charlist 0] + set char_b [lindex $charlist 1] + set char_ab ${char_a}${char_b} + set char_y [lindex $charlist end-1] + set char_z [lindex $charlist end] + set char_yz ${char_y}${char_z} + + if { ("{" in $charlist) || ("}" in $charlist) } { + dict set iteminfo has_braces 1 + set innerchars [lrange $charlist 1 end-1] + if {("{" in $innerchars) || ("}" in $innerchars)} { + dict set iteminfo has_inner_braces 1 + } else { + dict set iteminfo has_inner_braces 0 + } + } else { + dict set iteminfo has_braces 0 + dict set iteminfo has_inner_braces 0 + } + + #todo - brace/char counting to determine if actually 'wrapped' + #e.g we could have list element {((abc)} - which appears wrapped if only looking at first and last chars. + #also {(x) (y)} as a list member.. how to treat? + if {$itemlen <= 1} { + dict set iteminfo apparentwrap "not" + } else { + #todo - switch on $char_a$char_z + if {($char_a eq {"}) && ($char_z eq {"})} { + dict set iteminfo apparentwrap "doublequotes" + } elseif {($char_a eq "'") && ($char_z eq "'")} { + dict set iteminfo apparentwrap "singlequotes" + } elseif {($char_a eq "(") && ($char_z eq ")")} { + dict set iteminfo apparentwrap "brackets" + } elseif {($char_a eq "\{") && ($char_z eq "\}")} { + dict set iteminfo apparentwrap "braces" + } elseif {($char_a eq "^") && ($char_z eq "^")} { + dict set iteminfo apparentwrap "carets" + } elseif {($char_a eq "\[") && ($char_z eq "\]")} { + dict set iteminfo apparentwrap "squarebrackets" + } elseif {($char_a eq "`") && ($char_z eq "`")} { + dict set iteminfo apparentwrap "backquotes" + } elseif {($char_a eq "\n") && ($char_z eq "\n")} { + dict set iteminfo apparentwrap "lf-newline" + } elseif {($char_ab eq "\r\n") && ($char_yz eq "\r\n")} { + dict set iteminfo apparentwrap "crlf-newline" + } else { + dict set iteminfo apparentwrap "not-determined" + } + + } + dict set iteminfo wrapbalance "unknown" ;#a hint to caller that apparentwrap is only a guide. todo - possibly make wrapbalance indicate 0 for unbalanced.. and positive numbers for outer-count of wrappings. + #e.g {((x)} == 0 {((x))} == 1 {(x) (y (z))} == 2 + dict set iteminfo head_tail_chars [list $char_a $char_z] + set namemap [list \ + \r cr\ + \n lf\ + {"} doublequote\ + {'} singlequote\ + "`" backquote\ + "^" caret\ + \t tab\ + " " sp\ + "\[" lsquare\ + "\]" rsquare\ + "(" lbracket\ + ")" rbracket\ + "\{" lbrace\ + "\}" rbrace\ + \\ backslash\ + / forwardslash\ + ] + if {[string length $char_a]} { + set char_a_name [string map $namemap $char_a] + } else { + set char_a_name "emptystring" + } + if {[string length $char_z]} { + set char_z_name [string map $namemap $char_z] + } else { + set char_z_name "emptystring" + } + + dict set iteminfo head_tail_names [list $char_a_name $char_z_name] + dict set iteminfo len $itemlen + dict set iteminfo difflen $diff ;#2 for braces, 1 for quoting?, or 0. + dict set info $i $iteminfo + incr i + } + return $info + } + + + #parse bracketed expression (e.g produced by vim "shellxquote=(" ) into a tcl (nested) list + #e.g {(^c:/my spacey/path^ >^somewhere^)} + #e.g {(blah (etc))}" + #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} + # - because it also supports the perhaps less likely case of: {( ...) unbraced (...)} etc + # Note that + #maintenance warning - duplication in branches for bracketed vs unbracketed! + proc parse_cmd_brackets {str} { + #wordwrappers currently best suited to non-bracket entities - no bracket matching within - anything goes until end-token reached. + # - but.. they only take effect where a word can begin. so a[x y] may be split at the space unless it's within some other wraper e.g " a[x y]" will not break at the space + # todo - consider extending the in-word handling of word_bdepth which is currently only applied to () i.e aaa(x y) is supported but aaa[x y] is not as the space breaks the word up. + set wordwrappers [list \ + "\"" [list "\"" "\"" "\""]\ + {^} [list "\"" "\"" "^"]\ + "'" [list "'" "'" "'"]\ + "\{" [list "\{" "\}" "\}"]\ + {[} [list {[} {]} {]}]\ + ] ;#dict mapping start_character to {replacehead replacetail expectedtail} + set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. + #puts "pb:$str" + set in_bracket 0 + set in_word 0 + set word "" + set result {} + set word_bdepth 0 + set word_bstack [list] + set wordwrap "" ;#only one active at a time + set bracketed_elements [dict create] + foreach char [split $str ""] { + #puts "c:$char bracketed:$bracketed_elements" + if {$in_bracket > 0} { + if {$in_word} { + if {[string length $wordwrap]} { + #anything goes until end-char + #todo - lookahead and only treat as closing if before a space or ")" ? + lassign [dict get $wordwrappers $wordwrap] _open closing endmark + if {$char eq $endmark} { + set wordwrap "" + append word $closing + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } else { + append word $char + } + } else { + if {$word_bdepth == 0} { + #can potentially close off a word - or start a new one if word-so-far is a shell-special + if {$word in $shell_specials} { + if {$char eq ")"} { + dict lappend bracketed_elements $in_bracket $word + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + set word "" + set in_word 0 + } elseif {[regexp {[\s]} $char]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + incr in_bracket + } else { + #at end of shell-specials is another point to look for word started by a wordwrapper char + #- expect common case of things like >^/my/path^ + if {$char in [dict keys $wordwrappers]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 1 ;#just for explicitness.. we're straight into the next word. + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + #something unusual.. keep going with word! + append word $char + } + } + } else { + + if {$char eq ")"} { + dict lappend bracketed_elements $in_bracket $word + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + set word "" + set in_word 0 + } elseif {[regexp {[\s]} $char]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + #ordinary word up-against and opening bracket - brackets are part of word. + incr word_bdepth + append word "(" + } else { + append word $char + } + } + } else { + #currently only () are used for word_bdepth - todo add all or some wordwrappers chars so that the word_bstack can have multiple active. + switch -- $char { + "(" { + incr word_bdepth + lappend word_bstack $char + append word $char + } + ")" { + incr word_bdepth -1 + set word_bstack [lrange $word_bstack 0 end-1] + append word $char + } + default { + #spaces and chars added to word as it's still in a bracketed section + append word $char + } + } + } + } + } else { + + if {$char eq "("} { + incr in_bracket + + } elseif {$char eq ")"} { + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + } elseif {[regexp {[\s]} $char]} { + # + } else { + #first char of word - look for word-wrappers + if {$char in [dict keys $wordwrappers]} { + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + set word $char + } + set in_word 1 + } + } + } else { + if {$in_word} { + if {[string length $wordwrap]} { + lassign [dict get $wordwrappers $wordwrap] _open closing endmark + if {$char eq $endmark} { + set wordwrap "" + append word $closing + lappend result $word + set word "" + set in_word 0 + } else { + append word $char + } + } else { + + if {$word_bdepth == 0} { + if {$word in $shell_specials} { + if {[regexp {[\s]} $char]} { + lappend result $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + lappend result $word + set word "" + set in_word 0 + incr in_bracket + } else { + #at end of shell-specials is another point to look for word started by a wordwrapper char + #- expect common case of things like >^/my/path^ + if {$char in [dict keys $wordwrappers]} { + lappend result $word + set word "" + set in_word 1 ;#just for explicitness.. we're straight into the next word. + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + #something unusual.. keep going with word! + append word $char + } + } + + } else { + if {[regexp {[\s)]} $char]} { + lappend result $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + incr word_bdepth + append word $char + } else { + append word $char + } + } + } else { + switch -- $char { + "(" { + incr word_bdepth + append word $char + } + ")" { + incr word_bdepth -1 + append word $char + } + default { + append word $char + } + } + } + } + } else { + if {[regexp {[\s]} $char]} { + #insig whitespace(?) + } elseif {$char eq "("} { + incr in_bracket + dict set bracketed_elements $in_bracket [list] + } elseif {$char eq ")"} { + error "unbalanced bracket - unable to proceed result so far: $result bracketed_elements:$bracketed_elements" + } else { + #first char of word - look for word-wrappers + if {$char in [dict keys $wordwrappers]} { + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + set word $char + } + set in_word 1 + } + } + } + #puts "----$bracketed_elements" + } + if {$in_bracket > 0} { + error "shellfilter::parse_cmd_brackets missing close bracket. input was '$str'" + } + if {[dict exists $bracketed_elements 0]} { + #lappend result [lindex [dict get $bracketed_elements 0] 0] + lappend result [dict get $bracketed_elements 0] + } + if {$in_word} { + lappend result $word + } + return $result + } + + #only double quote if argument not quoted with single or double quotes + proc dquote_if_not_quoted {a} { + set wrapchars [string cat [string range $a 0 0] [string range $a end end]] + switch -- $wrapchars { + {""} - {''} { + return $a + } + default { + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + } + } + + #proc dquote_if_not_bracketed/braced? + + #wrap in double quotes if not double-quoted + proc dquote_if_not_dquoted {a} { + set wrapchars [string cat [string range $a 0 0] [string range $a end end]] + switch -- $wrapchars { + {""} { + return $a + } + default { + #escape any inner quotes.. + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + } + } + proc dquote {a} { + #escape any inner quotes.. + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + proc get_scriptrun_from_cmdlist_dquote_if_not {cmdlist {shellcmdflag ""}} { + set scr [auto_execok "script"] + if {[string length $scr]} { + #set scriptrun "( $c1 [lrange $cmdlist 1 end] )" + set arg1 [lindex $cmdlist 0] + if {[string first " " $arg1]>0} { + set c1 [dquote_if_not_quoted $arg1] + #set c1 "\"$arg1\"" + } else { + set c1 $arg1 + } + + if {[string length $shellcmdflag]} { + set scriptrun "$shellcmdflag \$($c1 " + } else { + set scriptrun "\$($c1 " + } + #set scriptrun "$c1 " + foreach a [lrange $cmdlist 1 end] { + #set a [string map [list "/" "//"] $a] + #set a [string map [list "\"" "\\\""] $a] + if {[string first " " $a] > 0} { + append scriptrun [dquote_if_not_quoted $a] + } else { + append scriptrun $a + } + append scriptrun " " + } + set scriptrun [string trim $scriptrun] + append scriptrun ")" + #return [list $scr -q -e -c $scriptrun /dev/null] + return [list $scr -e -c $scriptrun /dev/null] + } else { + return $cmdlist + } + } + + proc ::shellfilter::trun {commandlist args} { + #jmn + } + + + # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) + # By the point run is called - any transforms should already be in place on the channels if they're needed. + # The tees will be inline with none,some or all of those transforms depending on how the stack was configured + # (upstream,downstream configured via -float,-sink etc) + proc ::shellfilter::run {commandlist args} { + #must be a list. If it was a shell commandline string. convert it elsewhere first. + + variable sources + set runtag "shellfilter-run" + #set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] + set tid [::shellfilter::log::open $runtag [list -syslog ""]] + if {[catch {llength $commandlist} listlen]} { + set listlen "" + } + ::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]" + + #flush stdout + #flush stderr + + #adding filters with sink-aside will temporarily disable the existing redirection + #All stderr/stdout from the shellcommand will now tee to the underlying stderr/stdout as well as the configured syslog + + set defaults [dict create \ + -teehandle command \ + -outchan stdout \ + -errchan stderr \ + -inchan stdin \ + -tclscript 0 \ + ] + set opts [dict merge $defaults $args] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set outchan [dict get $opts -outchan] + set errchan [dict get $opts -errchan] + set inchan [dict get $opts -inchan] + set teehandle [dict get $opts -teehandle] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set is_script [dict get $opts -tclscript] + dict unset opts -tclscript ;#don't pass it any further + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set teehandle_out ${teehandle}out ;#default commandout + set teehandle_err ${teehandle}err + set teehandle_in ${teehandle}in + + + #puts stdout "shellfilter initialising tee_to_pipe transforms for in/out/err" + + # sources should be added when stack::new called instead(?) + foreach source [list $teehandle_out $teehandle_err] { + if {$source ni $sources} { + lappend sources $source + } + } + set outdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_out device] + set outpipechan [dict get $outdeviceinfo localchan] + set errdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_err device] + set errpipechan [dict get $errdeviceinfo localchan] + + #set indeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_in device] + #set inpipechan [dict get $indeviceinfo localchan] + + #NOTE:These transforms are not necessarily at the top of each stack! + #The float/sink mechanism, along with whether existing transforms are diversionary decides where they sit. + set id_out [shellfilter::stack::add $outchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_out -pipechan $outpipechan]] + set id_err [shellfilter::stack::add $errchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_err -pipechan $errpipechan]] + + # need to use os level channel handle for stdin - try named pipes (or even sockets) instead of fifo2 for this + # If non os-level channel - the command can't be run with the redirection + # stderr/stdout can be run with non-os handles in the call - + # but then it does introduce issues with terminal-detection and behaviour for stdout at least + # + # input is also a tee - we never want to change the source at this point - just log/process a side-channel of it. + # + #set id_in [shellfilter::stack::add $inchan tee_to_pipe -action sink-aside -settings [list -tag commandin -pipechan $inpipechan]] + + + #set id_out [shellfilter::stack::add stdout tee_to_log -action sink-aside -settings [list -tag shellstdout -syslog 127.0.0.1:514 -file ""]] + #set id_err [shellfilter::stack::add stderr tee_to_log -action sink-aside -settings [list -tag shellstderr -syslog 127.0.0.1:514 -file "stderr.txt"]] + + #we need to catch errors - and ensure stack::remove calls occur. + #An error can be raised if the command couldn't even launch, as opposed to a non-zero exitcode and stderr output from the command itself. + # + if {!$is_script} { + set experiment 0 + if $experiment { + try { + set results [exec {*}$commandlist] + set exitinfo [list exitcode 0] + } trap CHILDSTATUS {results options} { + set exitcode [lindex [dict get $options -errorcode] 2] + set exitinfo [list exitcode $exitcode] + } + } else { + if {[catch { + #run process with stdout/stderr/stdin or with configured channels + #set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan $inpipechan {*}$opts] + set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan stdin {*}$opts] + #puts stderr "---->exitinfo $exitinfo" + + #subprocess result should usually have an "exitcode" key + #but for background execution we will get a "pids" key of process ids. + } errMsg]} { + set exitinfo [list error "$errMsg" source shellcommand_stdout_stderr] + } + } + } else { + if {[catch { + #script result + set exitinfo [list result [uplevel #0 [list eval $commandlist]]] + } errMsg]} { + set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] + } + } + + + #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal + #Remove execution-time Tees from stack + shellfilter::stack::remove stdout $id_out + shellfilter::stack::remove stderr $id_err + #shellfilter::stack::remove stderr $id_in + + + #chan configure stderr -buffering line + #flush stdout + + + ::shellfilter::log::write $runtag " return '$exitinfo'" + ::shellfilter::log::close $runtag + return $exitinfo + } + proc ::shellfilter::logtidyup { {tags {}} } { + variable sources + set worker_errorlist [list] + set tidied_sources [list] + set tidytag "logtidy" + + + # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea. + # we should ensure the thread already exists early on if we really need logging here. + # + #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] + #::shellfilter::log::write $tidytag " logtidyuptags '$tags'" + + foreach s $sources { + if {$s eq $tidytag} { + continue + } + #puts "logtidyup source $s" + set close 1 + if {[llength $tags]} { + if {$s ni $tags} { + set close 0 + } + } + if {$close} { + lappend tidied_sources $s + shellfilter::log::close $s + lappend worker_errorlist {*}[shellthread::manager::get_and_clear_errors $s] + } + } + set remaining_sources [list] + foreach s $sources { + if {$s ni $tidied_sources} { + lappend remaining_sources $s + } + } + + #set sources [concat $remaining_sources $tidytag] + set sources $remaining_sources + + #shellfilter::stack::unwind stdout + #shellfilter::stack::unwind stderr + return [list tidied $tidied_sources errors $worker_errorlist] + } + + #package require tcl::chan::null + # e.g set errchan [tcl::chan::null] + # e.g chan push stdout [shellfilter::chan::var new ::some_var] + proc ::shellfilter::shellcommand_stdout_stderr {commandlist outchan errchan inchan args} { + set valid_flags [list \ + -timeout \ + -outprefix \ + -errprefix \ + -debug \ + -copytempfile \ + -outbuffering \ + -errbuffering \ + -inbuffering \ + -readprocesstranslation \ + -outtranslation \ + -stdinhandler \ + -outchan \ + -errchan \ + -inchan \ + -teehandle\ + ] + + set runtag shellfilter-run2 + #JMN - load from config + #set tid [::shellfilter::log::open $runtag [list -syslog "127.0.0.1:514"]] + set tid [::shellfilter::log::open $runtag [list -syslog ""]] + + if {[llength $args] % 2} { + error "Trailing arguments after any positional arguments must be in pairs of the form -argname argvalue. Valid flags are:'$valid_flags'" + } + set invalid_flags [list] + foreach {k -} $args { + switch -- $k { + -timeout - + -outprefix - + -errprefix - + -debug - + -copytempfile - + -outbuffering - + -errbuffering - + -inbuffering - + -readprocesstranslation - + -outtranslation - + -stdinhandler - + -outchan - + -errchan - + -inchan - + -teehandle { + } + default { + lappend invalid_flags $k + } + } + } + if {[llength $invalid_flags]} { + error "Unknown option(s)'$invalid_flags': must be one of '$valid_flags'" + } + #line buffering generally best for output channels.. keeps relative output order of stdout/stdin closer to source order + #there may be data where line buffering is inappropriate, so it's configurable per std channel + #reading inputs with line buffering can result in extraneous newlines as we can't detect trailing data with no newline before eof. + set defaults [dict create \ + -outchan stdout \ + -errchan stderr \ + -inchan stdin \ + -outbuffering none \ + -errbuffering none \ + -readprocesstranslation auto \ + -outtranslation lf \ + -inbuffering none \ + -timeout 900000\ + -outprefix ""\ + -errprefix ""\ + -debug 0\ + -copytempfile 0\ + -stdinhandler ""\ + ] + + + + set args [dict merge $defaults $args] + set outbuffering [dict get $args -outbuffering] + set errbuffering [dict get $args -errbuffering] + set inbuffering [dict get $args -inbuffering] + set readprocesstranslation [dict get $args -readprocesstranslation] + set outtranslation [dict get $args -outtranslation] + set timeout [dict get $args -timeout] + set outprefix [dict get $args -outprefix] + set errprefix [dict get $args -errprefix] + set debug [dict get $args -debug] + set copytempfile [dict get $args -copytempfile] + set stdinhandler [dict get $args -stdinhandler] + + set debugname "shellfilter-debug" + + if {$debug} { + set tid [::shellfilter::log::open $debugname [list -syslog "127.0.0.1:514"]] + ::shellfilter::log::write $debugname " commandlist '$commandlist'" + } + #'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp. + # a simple counter would probably work too + #consider other options if an alternative to the single vwait in this function is used. + set call_id [tcl::clock::microseconds] ; + set ::shellfilter::shellcommandvars($call_id,exitcode) "" + set waitvar ::shellfilter::shellcommandvars($call_id,waitvar) + if {$debug} { + ::shellfilter::log::write $debugname " waitvar '$waitvar'" + } + lassign [chan pipe] rderr wrerr + chan configure $wrerr -blocking 0 + + set custom_stderr "" + set lastitem [lindex $commandlist end] + #todo - ensure we can handle 2> file (space after >) + + #review - reconsider the handling of redirections such that tcl-style are handled totally separately to other shell syntaxes! + # + #note 2>@1 must ocur as last word for tcl - but 2@stdout can occur elsewhere + #(2>@stdout echoes to main stdout - not into pipeline) + #To properly do pipelines it looks like we will have to split on | and call this proc multiple times and wire it up accordingly (presumably in separate threads) + + switch -- [string trim $lastitem] { + {&} { + set name [lindex $commandlist 0] + #background execution - stdout and stderr from child still comes here - but process is backgrounded + #FIX! - this is broken for paths with backslashes for example + #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]] + set pidlist [exec {*}$commandlist] + return [list pids $pidlist] + } + {2>&1} - {2>@1} { + set custom_stderr {2>@1} ;#use the tcl style + set commandlist [lrange $commandlist 0 end-1] + } + default { + # 2> filename + # 2>> filename + # 2>@ openfileid + set redir2test [string range $lastitem 0 1] + if {$redir2test eq "2>"} { + set custom_stderr $lastitem + set commandlist [lrange $commandlist 0 end-1] + } + } + } + set lastitem [lindex $commandlist end] + + set teefile "" ;#empty string, write, append + #an ugly hack.. because redirections seem to arrive wrapped - review! + #There be dragons here.. + #Be very careful with list manipulation of the commandlist string.. backslashes cause havoc. commandlist must always be a well-formed list. generally avoid string manipulations on entire list or accidentally breaking a list element into parts if it shouldn't be.. + #The problem here - is that we can't always know what was intended on the commandline regarding quoting + + ::shellfilter::log::write $runtag "checking for redirections in $commandlist" + #sometimes we see a redirection without a following space e.g >C:/somewhere + #normalize + switch -regexp -- $lastitem\ + {^>[/[:alpha:]]+} { + set lastitem "> [string range $lastitem 1 end]" + }\ + {^>>[/[:alpha:]]+} { + set lastitem ">> [string range $lastitem 2 end]" + } + + + #for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}} + #or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces} + #we can't use list methods such as llenth on a member of commandlist + set wordlike_parts [regexp -inline -all {\S+} $lastitem] + + if {([llength $wordlike_parts] >= 2) && ([lindex $wordlike_parts 0] in [list ">>" ">"])} { + #wrapped redirection - but maybe not 'well' wrapped (unquoted filename) + set lastitem [string trim $lastitem] ;#we often see { > something} + + #don't use lassign or lrange on the element itself without checking first + #we can treat the commandlist as a whole as a well formed list but not neccessarily each element within. + #lassign $lastitem redir redirtarget + #set commandlist [lrange $commandlist 0 end-1] + # + set itemchars [split $lastitem ""] + set firstchar [lindex $itemchars 0] + set lastchar [lindex $itemchars end] + + #NAIVE test for double quoted only! + #consider for example {"a" x="b"} + #testing first and last is not decisive + #We need to decide what level of drilling down is even appropriate here.. + #if something was double wrapped - it was perhaps deliberate so we don't interpret it as something(?) + set head_tail_chars [list $firstchar $lastchar] + set doublequoted [expr {[llength [lsearch -all $head_tail_chars "\""]] == 2}] + if {[string equal "\{" $firstchar] && [string equal "\}" $lastchar]} { + set curlyquoted 1 + } else { + set curlyquoted 0 + } + + if {$curlyquoted} { + #these are not the tcl protection brackets but ones supplied in the argument + #it's still not valid to use list operations on a member of the commandlist + set inner [string range $lastitem 1 end-1] + #todo - fix! we still must assume there could be list-breaking data! + set innerwords [regexp -inline -all {\S+} $inner] ;#better than [split $inner] because we don't get extra empty elements for each whitespace char + set redir [lindex $innerwords 0] ;#a *potential* redir - to be tested below + set redirtarget [lrange $innerwords 1 end] ;#all the rest + } elseif {$doublequoted} { + ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" + set inner [string range $lastitem 1 end-1] + set innerwords [regexp -inline -all {\S+} $inner] + set redir [lindex $innerwords 0] + set redirtarget [lrange $innerwords 1 end] + } else { + set itemwords [regexp -inline -all {\S+} $lastitem] + # e.g > c:\test becomes > {c:\test} + # but > c/mnt/c/test/temp.txt stays as > /mnt/c/test/temp.txt + set redir [lindex $itemwords 0] + set redirtarget [lrange $itemwords 1 end] + } + set commandlist [lrange $commandlist 0 end-1] + + } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} { + #unwrapped redirection + #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list + set redir [lindex $commandlist end-1] + set redirtarget [lindex $commandlist end] + set commandlist [lrange $commandlist 0 end-2] + } else { + #no redirection + set redir "" + set redirtarget "" + #no change to command list + } + + + switch -- $redir { + ">>" - ">" { + set redirtarget [string trim $redirtarget "\""] + ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'" + + set winfile $redirtarget ;#default assumption + switch -glob -- $redirtarget { + "/c/*" { + set winfile "c:/[string range $redirtarget 3 end]" + } + "/mnt/c/*" { + set winfile "c:/[string range $redirtarget 7 end]" + } + } + + if {[file exists [file dirname $winfile]]} { + #containing folder for target exists + if {$redir eq ">"} { + set teefile "write" + } else { + set teefile "append" + } + ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile" + } else { + #we should be writing to a file.. but can't + ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'" + } + } + default { + ::shellfilter::log::write $runtag "No redir found!!" + } + } + + #often first element of command list is wrapped and cannot be run directly + #e.g {{ls -l} {> {temp.tmp}}} + #we will assume that if there is a single element which is a pathname containing a space - it is doubly wrapped. + # this may not be true - and the command may fail if it's just {c:\program files\etc} but it is the less common case and we currently have no way to detect. + #unwrap first element.. will not affect if not wrapped anyway (subject to comment above re spaces) + set commandlist [concat [lindex $commandlist 0] [lrange $commandlist 1 end]] + + #todo? + #child process environment. + # - to pass a different environment to the child - we would need to save the env array, modify as required, and then restore the env array. + + #to restore buffering states after run + set remember_in_out_err_buffering [list \ + [chan configure $inchan -buffering] \ + [chan configure $outchan -buffering] \ + [chan configure $errchan -buffering] \ + ] + + set remember_in_out_err_translation [list \ + [chan configure $inchan -translation] \ + [chan configure $outchan -translation] \ + [chan configure $errchan -translation] \ + ] + + + + + + chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok + chan configure $errchan -buffering $errbuffering + #chan configure $outchan -blocking 0 + chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. + # + + #-------------------------------------------- + #Tested on windows. Works to stop in output when buffering is none, reading from channel with -translation auto + #cmd, pwsh, tcl + #chan configure $outchan -translation lf + #chan configure $errchan -translation lf + #-------------------------------------------- + chan configure $outchan -translation $outtranslation + chan configure $errchan -translation $outtranslation + + #puts stderr "chan configure $wrerr [chan configure $wrerr]" + if {$debug} { + ::shellfilter::log::write $debugname "COMMAND [list $commandlist] strlen:[string length $commandlist] llen:[llength $commandlist]" + } + #todo - handle custom redirection of stderr to a file? + if {[string length $custom_stderr]} { + #::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist $custom_stderr] a+" + #set rdout [open |[concat $commandlist $custom_stderr] a+] + ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list $custom_stderr <@$inchan]] [list RDONLY]" + set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] + set rderr "bogus" ;#so we don't wait for it + } else { + ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]" + #set rdout [open |[concat $commandlist [list 2>@$wrerr]] a+] + #set rdout [open |[concat $commandlist [list 2>@$wrerr]] [list RDWR]] + + # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. + # This is the whole reason we need these file-event loops. + # Ideally we need something like exec,open in tcl that interacts with transformed channels directly and emits as it runs, not only at termination + # - and that at least appears like a terminal to the called command. + #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] + + + set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] + + chan configure $rderr -buffering $errbuffering -blocking 0 + chan configure $rderr -translation $readprocesstranslation + } + + + + set command_pids [pid $rdout] + #puts stderr "command_pids: $command_pids" + #tcl::process ensemble only available in 8.7+ - and it didn't prove useful here anyway + # the child process generally won't shut down until channels are closed. + # premature EOF on grandchild process launch seems to be due to lack of terminal emulation when redirecting stdin/stdout. + # worked around in punk/repl using 'script' command as a fake tty. + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $command_pids 0] ni $subprocesses} { + # puts stderr "pid [lindex $command_pids 0] not running $errMsg" + #} else { + # puts stderr "pid [lindex $command_pids 0] is running" + #} + + + if {$debug} { + ::shellfilter::log::write $debugname "pipeline pids: $command_pids" + } + + #jjj + + + chan configure $rdout -buffering $outbuffering -blocking 0 + chan configure $rdout -translation $readprocesstranslation + + if {![string length $custom_stderr]} { + chan event $rderr readable [list apply {{chan other wrerr outchan errchan waitfor errprefix errbuffering debug debugname pids} { + if {$errbuffering eq "line"} { + set countchunk [chan gets $chan chunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + #errprefix only applicable to line buffered output + if {$countchunk >= 0} { + if {[chan eof $chan]} { + puts -nonewline $errchan ${errprefix}$chunk + } else { + puts $errchan "${errprefix}$chunk" + } + } + } else { + set chunk [chan read $chan] + if {[string length $chunk]} { + puts -nonewline $errchan $chunk + } + } + if {[chan eof $chan]} { + flush $errchan ;#jmn + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $pids 0] ni $subprocesses} { + # puts stderr "stderr reader: pid [lindex $pids 0] no longer running" + #} else { + # puts stderr "stderr reader: pid [lindex $pids 0] still running" + #} + chan close $chan + #catch {chan close $wrerr} + if {$other ni [chan names]} { + set $waitfor stderr + } + } + }} $rderr $rdout $wrerr $outchan $errchan $waitvar $errprefix $errbuffering $debug $debugname $command_pids] + } + + #todo - handle case where large amount of stdin coming in faster than rdout can handle + #as is - arbitrary amount of memory could be used because we aren't using a filevent for rdout being writable + # - we're just pumping it in to the non-blocking rdout buffers + # ie there is no backpressure and stdin will suck in as fast as possible. + # for most commandlines this probably isn't too big a deal.. but it could be a problem for multi-GB disk images etc + # + # + + ## Note - detecting trailing missing nl before eof is basically the same here as when reading rdout from executable + # - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read. + # Not known if that is significant + ## with inchan configured -buffering line + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl -r cat + #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl -r cat + #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:1 pend:-1 count:3 + #etc + + if 0 { + chan event $inchan readable [list apply {{chan wrchan inbuffering waitfor} { + #chan copy stdin $chan ;#doesn't work in a chan event + if {$inbuffering eq "line"} { + set countchunk [chan gets $chan chunk] + #puts $wrchan "stdinstate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + if {$countchunk >= 0} { + if {[chan eof $chan]} { + puts -nonewline $wrchan $chunk + } else { + puts $wrchan $chunk + } + } + } else { + set chunk [chan read $chan] + if {[string length $chunk]} { + puts -nonewline $wrchan $chunk + } + } + if {[chan eof $chan]} { + puts stderr "|stdin_reader>eof [chan configure stdin]" + chan event $chan readable {} + #chan close $chan + chan close $wrchan write ;#half close + #set $waitfor "stdin" + } + }} $inchan $rdout $inbuffering $waitvar] + + if {[string length $stdinhandler]} { + chan configure stdin -buffering line -blocking 0 + chan event stdin readable $stdinhandler + } + } + + set actual_proc_out_buffering [chan configure $rdout -buffering] + set actual_outchan_buffering [chan configure $outchan -buffering] + #despite whatever is configured - we match our reading to how we need to output + set read_proc_out_buffering $actual_outchan_buffering + + + + if {[string length $teefile]} { + set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]" + set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}] + if {$teefile eq "write"} { + ::shellfilter::log::write $logname "opening '$winfile' for write" + set fd [open $winfile w] + } else { + ::shellfilter::log::write $logname "opening '$winfile' for appending" + set fd [open $winfile a] + } + #chan configure $fd -translation lf + chan configure $fd -translation $outtranslation + chan configure $fd -encoding utf-8 + + set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds] + set $tempvar_bytetotal 0 + chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} { + #review - if we write outprefix to normal stdout.. why not to redirected file? + #usefulness of outprefix is dubious + upvar $bytevar totalbytes + if {$read_proc_out_buffering eq "line"} { + #set outchunk [chan read $chan] + set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + if {$countchunk >= 0} { + if {![chan eof $chan]} { + set numbytes [expr {[string length $outchunk] + 1}] ;#we are assuming \n not \r\n - but count won't/can't be completely accurate(?) - review + puts $writefilefd $outchunk + } else { + set numbytes [string length $outchunk] + puts -nonewline $writefilefd $outchunk + } + incr totalbytes $numbytes + ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" + #puts $outchan "${outprefix} wrote $numbytes bytes to $writefile" + } + } else { + set outchunk [chan read $chan] + if {[string length $outchunk]} { + puts -nonewline $writefilefd $outchunk + set numbytes [string length $outchunk] + incr totalbytes $numbytes + ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" + } + } + if {[chan eof $chan]} { + flush $writefilefd ;#jmn + #set blocking so we can get exit code + chan configure $chan -blocking 1 + catch {::shellfilter::log::write $logtag "${outprefix} total bytes $totalbytes written to $writefile"} + #puts $outchan "${outprefix} total bytes $totalbytes written to $writefile" + catch {close $writefilefd} + if {$copytempfile} { + catch {file copy $writefile "[file rootname $writefile]_copy[file extension $writefile]"} + } + try { + chan close $chan + set ::shellfilter::shellcommandvars($call_id,exitcode) 0 + if {$debug} { + ::shellfilter::log::write $debugname "(teefile) -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {$debug} { + ::shellfilter::log::write $debugname "(teefile) CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars($call_id,exitcode) $code + } + catch {chan close $wrerr} + if {$other ni [chan names]} { + set $waitfor stdout + } + } + }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $winfile $fd $copytempfile $tempvar_bytetotal $logname] + + } else { + + # This occurs when we have outbuffering set to 'line' - as the 'input' from rdout which comes from the executable is also configured to 'line' + # where b:0|1 is whether chan blocked $chan returns 0 or 1 + # pend is the result of chan pending $chan + # eof is the resot of chan eof $chan + + + ##------------------------- + ##If we still read with gets,to retrieve line by line for output to line-buffered output - but the input channel is configured with -buffering none + ## then we can detect the difference + # there is an extra blocking read - but we can stil use eof with data to detect the absent newline and avoid passing an extra one on. + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /u/c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:1 eof:0 pend:-1 count:-1 + #instate b:0 eof:1 pend:-1 count:3 + #etc + ##------------------------ + + + #this should only occur if upstream is coming from stdin reader that has line buffering and hasn't handled the difference properly.. + ###reading with gets from line buffered input with trailing newline + #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + ###reading with gets from line buffered input with trailing newline + ##No detectable difference! + #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + ##------------------------- + + #Note that reading from -buffering none and writing straight out gives no problem because we pass the newlines through as is + + + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($rdout) 0 ;#a very specific case of readblocked prior to eof.. possibly not important + #this detection is disabled for now - but left for debugging in case it means something.. or changes + chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname pids} { + #set outchunk [chan read $chan] + + if {$read_proc_out_buffering eq "line"} { + set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + #countchunk can be -1 before eof e.g when blocked + #debugging output inline with data - don't leave enabled + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + if {$countchunk >= 0} { + if {![chan eof $chan]} { + puts $outchan ${outprefix}$outchunk + } else { + puts -nonewline $outchan ${outprefix}$outchunk + #if {$::shellfilter::chan::lastreadblocked_nodata_noeof($chan)} { + # seems to be the usual case + #} else { + # #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior + # #Not known if this occurs + # #debugging output inline with data - don't leave enabled + # puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + #} + } + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) 0 + } else { + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) [expr {[chan blocked $chan] && ![chan eof $chan]}] + } + } else { + #puts $outchan "read CHANNEL $chan [chan configure $chan]" + #puts $outchan "write CHANNEL $outchan b:[chan configure $outchan -buffering] t:[chan configure $outchan -translation] e:[chan configure $outchan -encoding]" + set outchunk [chan read $chan] + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:[string length $outchunk]" + if {[string length $outchunk]} { + #set stringrep [encoding convertfrom utf-8 $outchunk] + #set newbytes [encoding convertto utf-16 $stringrep] + #puts -nonewline $outchan $newbytes + puts -nonewline $outchan $outchunk + } + } + + if {[chan eof $chan]} { + flush $outchan ;#jmn + #for now just look for first element in the pid list.. + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $pids 0] ni $subprocesses} { + # puts stderr "stdout reader pid: [lindex $pids 0] no longer running" + #} else { + # puts stderr "stdout reader pid: [lindex $pids 0] still running" + #} + + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan]" + chan configure $chan -blocking 1 ;#so we can get exit code + try { + chan close $chan + set ::shellfilter::shellcommandvars($call_id,exitcode) 0 + if {$debug} { + ::shellfilter::log::write $debugname " -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + set ::shellfilter::shellcommandvars($call_id,exitcode) $code + if {$debug} { + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code" + } + } trap CHILDKILLED {result options} { + #set code [lindex [dict get $options -errorcode] 2] + #set ::shellfilter::shellcommandvars(%id%,exitcode) $code + set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled" + if {$debug} { + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" + } + + } finally { + #puts stdout "HERE" + #flush stdout + + } + catch {chan close $wrerr} + if {$other ni [chan names]} { + set $waitfor stdout + } + + } + }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $command_pids] + } + + #todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data + #e.g x hrs with no data(?) + #reset timeout when data detected. + after $timeout [string map [list %w% $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { + if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} { + if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} { + catch { chan close %wrerr% } + catch { chan close %rdout%} + catch { chan close %rderr%} + } else { + chan configure %rdout% -blocking 1 + try { + chan close %rdout% + set ::shellfilter::shellcommandvars(%id%,exitcode) 0 + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars(%id%,exitcode) $code + } trap CHILDKILLED {result options} { + set code [lindex [dict get $options -errorcode] 2] + #set code [dict get $options -code] + #set ::shellfilter::shellcommandvars(%id%,exitcode) $code + #set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" + set ::shellfilter::shellcommandvars(%id%,exitcode) "childkilled-timeout" + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code" + ::shellfilter::log::write %debugname% "(timeout) result:$result options:$options" + } + + } + catch { chan close %wrerr% } + catch { chan close %rderr%} + } + set %w% "timeout" + } + }] + + + vwait $waitvar + + set exitcode [set ::shellfilter::shellcommandvars($call_id,exitcode)] + if {![string is digit -strict $exitcode]} { + puts stderr "Process exited with non-numeric code: $exitcode" + flush stderr + } + if {[string length $teefile]} { + #cannot be called from within an event handler above.. vwait reentrancy etc + catch {::shellfilter::log::close $logname} + } + + if {$debug} { + ::shellfilter::log::write $debugname " closed by: [set $waitvar] with exitcode: $exitcode" + catch {::shellfilter::log::close $debugname} + } + array unset ::shellfilter::shellcommandvars $call_id,* + + + #restore buffering to pre shellfilter::run state + lassign $remember_in_out_err_buffering bin bout berr + chan configure $inchan -buffering $bin + chan configure $outchan -buffering $bout + chan configure $errchan -buffering $berr + + lassign $remember_in_out_err_translation tin tout terr + chan configure $inchan -translation $tin + chan configure $outchan -translation $tout + chan configure $errchan -translation $terr + + + #in channel probably closed..(? review - should it be?) + catch { + chan configure $inchan -buffering $bin + } + + + return [list exitcode $exitcode] + } + +} + +package provide shellfilter [namespace eval shellfilter { + variable version + set version 0.1.9 +}] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm new file mode 100644 index 0000000000000000000000000000000000000000..34f2a73d9eca15bbe0cb8fc4abcdfe7f7a15647d GIT binary patch literal 41364 zcmce;2RxPU{|78(X3y*+viIJ5lTG$M_B@Uqva`38l^H@-iV)cnl9{~|Wfn?2_d!MV z{r-MWzyI@`URTFC_kCa2XMf(G&wbqo6?EoB}+aoXKDpzb_YXTZJZoImQMCC@@!l|00pk54&d+Kn7V>kpbp2({IZ}G z*bxjdg-z<_YU5}n0FVfqT0p?w#!NuK!PE|H4A5YF@-2wj$>9Sb}`?%}t@^)*zo_VLCcN98B$Pyul!S8%IkgkgGYw#u;kp z3tJg>0`Qm5xfx&r0z)8xD6gK9aV!<6o7u_NEFdjMQ!_xKfPgK)fczY69Ko>J+<@<# zO`+B-AUbC!S63U@Ij*LbU_d&+Sm56LNsR9AT>eLC?91Pfs^C zb+j-B%;xkOh?5ia_@a|3pr$tVKd(1DH-Wt=AW17nkiM(4y$$sEtRIsx8=i{&c!E=_ zJa_f6HT)_yfMV9~CJm$d`+R?tq^pw~#QcQ2f4YwK>?DBQpQFGR1h#ht|G~tlezP5z zL|g$M1FXggqsg!93X1*%{*G46y+m$KLDQ^e|%uj+vj>m@C*E3i1&LN&LyC zVW%F;!`>e3Xaz(VYH>r5urP=XI2i(lxuovtUaS*k{zn&lgq6Vh<<0*e;_4~p;e?DyK1Ob}@vBeXh4CDhl znU30%{vQQ*=5&ca*uV)Rr}90HPN&WdoAi(7`27mlyFFkQKw3DFljk3Kgq`+hM*jTm zsU7@LX1`wnW8dD~)D>)e5{Zpn!B!4nM<6)q!y=ud6%ZorojiWH{ZAJLT*=VzH;RAG zcM?ru!PFJT!te7z&FuvQpboIS;R^l3RNn<}Z*J@Wn+8OELg?9ve-HbxrC>xHUvh?< z;|Ov}{r4GvCm(k8IZpu+4iNZ{o$_?~U*$x7ekH?W&-&>jza0Hf4g(8=XQ;M^m^xYk zY40rcC!yQ$j35581_-byLy#bq8xXW$K?e*0fB{U$79iO4zv&FdH0)&t_=VjckN$2q zzkhR1Y}DuY_(wN@Daz8#-u@Jofb?yh02rcg?&Juhf6)0!j`IePpJ6i_f&>I$9Kx;z z9cLjYOCWC_LmLo)Tma53V1VZPSCA9P^+(>0jRh8>je#Xka|-K;z>lf%Vemaqh#@TV z0Ox}(m;qJ5K-Jmg@!J~zm_1-3|5X66nNE59ZKChzA1{8E*#CFrp#C=TvF46Lm${RJ z1CZujLC3xcLumjIJzmcc1OTL~SO3X;sZ1eOZm_rkz*iWaG`EJ?Ensg>ATuBf0%!^F zaoFKwT>Ks13J6?3&W&KG`ENwQxTOM{!c6xR6}SqVK;-XN9n<9u7z`BlJq{tNj zkgiSur20-f2rw>tu&FB)WCcUO4lqaryjy_nO}$(}01)@EakOyqa0NNrn?ixe2Ow_% zy*fHMG9RZCQ-B5fKU1b@4Fm7Mg+P*Ya{y4S7m!VWNlv8C$_gj|M%xL11(E~sJ>Vgx zfIgufP7u3exO*Ng!bA^y{qT%qxd0i#0zkeXJ1{`7{_h6z&%yL6E9;3V!BEzTqg@3# z+Q1wd_;fP)KN%K`4ghAkI@>_OAaPasQ_DJIpg)}aRMa33SO5UZ1PIg(D2rf4k)so! zI%kVxnJ}LsvlE5dIXZa&Wyv|)g_)?68x#bEcpVE4`e*6DC_DC?(@N!!+JT(}dr|!+ zuODC;^g}xT=Ep#=gB5dN2N*xDKt_hG4Lw!8DaZrj1nAhx4eaU)qBDg+Z7hMZ4+I27 zQ&<*-IVMoC0GdBzyMWEOx`9EWe>STVvH`-K-2g0b^I#&f zA|fJZO!qXlf`njd0gBl-+l0j7A$lE9y?J$upVM6Pb;=3p?;Y%l;~ z6AWdYjpRS=?Wa3}ez14Gr2Q_}v+w6vlY~WfSipC4wt|>i9OFfx=>Y-!+6IVzK==pD z?j-12+IRv6cuWb*k^g<6-{Hk~68`zfiB8X2`0r}`W6}6)@%JA!d`<)>7y$HLyT|H) zMf<;8{8aIP=1xR)JRgwy^v`@W{CDA<3pQ?!ClvjGo`3a_)Aq^FK8YoeppMPtd#w#? z4*?hpaFOFC%yGgxfiEEHGobFDY5lV*eg7NBI(I(d-1czNx(j zES)P_W<+INWy(_1jD^N1;-dU;*6#;Kea&F$ZuxkUe3d zI7R^uU<+6q0tCp-6~qkmAAwv496PZS0LcKD8iov9|E!4L-3(>{u*S-dVEL~O1iSuw z+O0pP`2h_8v7K=D-9CZ$?`90-OF-u*-UR~+rtU!G zJ#G%3^k;wR@_mm(-``IQcn5$Cz-O<@TLQr9q_2B2<=J+wDFiUaAJa3RO8vO$2(!u) z(F3-5+%vWSnRx*?(a{ai{b^s<`8d7;syYsGKO7HM=-2~2CzgM9H5j$OP^t;cbKETk zTFM{*8v!5!rg>nsQ}+N0Ef{0~W;gxb6o!H9pS@%l0Y9X8>TAa>WM_a;!2M2p%K#kv zPU^oCcoK4`0a5l{QnTYVaxnEhX3=CKcD|ghZa!ONty6piS;*8oL}So zC)gdD9|jK?C=g74wibz16)#@GgM))ZhHFZ_sW-=l>YI8A4o;i^4o(;j3GRFTfjT(= zEh}qgb{60ttE(GOnz*vUJP7ERxtRl9Sn&BzEU^0U=;$IG+y(d#Iu1_bJXnYJ-y(wU zsa)Uy?Z2a>sN)_DTm)MS<4M|Isg@fzpi@t#>nOT^)F`N4NzX6u079sv#4wXvnB1Jo zT&9*KQv5h3A;!{}#6f6+3zjy`m8;Ukd&($Qk{UQ0m-0;lAHC)o$15dAn`t|Yu#VRz zZICWYRJW14awRhlusWI{W&?xP99(q4Z7q@Ny0jd(5#8`+dB@-t2cW~6X+mHHKd^Q} z&iJ)EuX(dyqjMsuQ8VF^rY_yj!{@L2R^A%fu7+-`5Y%X2DnUt5)KAbCj0?@{nJIMn zU}3qJ>*_3aw2-fpF5yO4RY5kcE962X5PRc+OK@aRGt*(X6G7ixA%33%O03Iv-$M+VF>rkRplC*K336am|epQhiAOcOy6lXuA#}f;pX7$y~S5~ zvz0{N*$_;@$<8lz0h4KWcqWYE#n+B%qR#@s{I?RNPztc&wH7w|-?rH6U&#%9PCRL3 zZ0PretoZd;<1&`}wuxaGP}j}<_ghQwgQQL(6EQM`6o*guNQxsGyMpRMT?<8`MU18n z5FfrNLv?g?@a7|P+%9o)mB`%vnmSw@fl*{v_xUaKvA~DPtk=82$S6lfb9wZvoY!ze zIefiQp{RUIOIIK?*b+)Xovw*giYVyaY%vSe+@Hy;Qt)|LarKwxl1Epf(~Kh1I^PJE zKr44>KeTCa4}GcAQF>eM{h(Hvk9}9rbZ23XKQSUS)uyiS?!<)tsLXa&^Zu@sSK1I< zn=sZqnpm7NZZ4bsi;6IdA^f1E?&$f859CrJlexgzaiL; z9Y~8sce<~Lbbf8eTnyOs-?%{BafM1sP8xGO08xY+T-zlTbE{L@jDWahH+GgTiNNFz zd~cI*2;u#x*4$Q;uRk#=YGTYEDWfAc0HDa;wesYe}%j#gqd8s2xi`|E(AJYN1 zd07JgRyj&sQ6bf~a*1vPW_(gOo*+t)niNJVD(_4BISF>D6*OE4^Jy?@zD>uQ(X4gR znDVS(p9^E*>*I8o+?i>;**(43(+eT0%`Or`<{?TTYo-y$P22>UJC}>@64!BW?a>!q zSDg15@2^t4u_nJ2FlA+Y71fPLRb+59G(%w6sH7dkxB+y4qyORQSb13N14$5iiZ|&1 z!!FHD|CzFH)eVQMw$QPtiI2e;#Hl8lEsvh?QWc8$Uu_-y=GAD3K{8GALHh%e=jsH@ zE4N7_D(Ts0n86=wc}WU8iQw%!GW+xs)3CqYp3S<50q(wAjw$i(7UKituSMF^K^*=} zDL3akd1HY8Zp?O4WD@0yTV-STqbwmyGrpJ(%=N$UGxA-GV9=H4b2GRFM7}4N;o!L8 z5dJ;#L4aUw0o*HaX8rNkX~eq#2bZC(=rqrRC8GG;jNzqoWg!mr1BozUmbWeN($9qP zjJWS#>sFHt*GuT8K|Yuk3w`)?SQ$&u^N~#z#%TeV}W-c%^^7P5GIRD)*xlMB@djFHW}BX|%c*$Yo2E)$$+*3))brlg*1TW>6ezVtNmL>~6Ja(yG=iWY$ zBo#(|b2~#~@_|u`vNmrVb>yP@lhTi!suuZ|@0!NbMdV7N?X4j7B)cVZA>!zpB^VB+ zlGX&1ZX~lc)vVZ}`#qyeaDA0gKCl{3OM!T3CQj^=wQTwfZs$6@#X%Wis)nFy`!Y@z zL7HJa>KN*$>5s`%;=?v*p3GC&V-*uYE>l%V@xJcAJP!8=2wQd{wYo9?9GpAn%JHHMd-3 zQiPxHYFK8i8ngaz^eHek{I;HHK9*$FIsroBM_h&jiM*_q24z|2Y{%i*o}6A2Mm{tn zb))yx)L$t1*>W@Z_(^rZat(4e7Vqh5MXvMRD6}VSfdEKFIH_! zpMpJuux=zlz?1MPYpm|o@X(!4efwWr8xMu)4^&&2*l#4nt{?7A%)K^m-A+mfxh9Gn zVjg&1HSy@fz3~lLQ56eCA@i1N zdDr*!O$|Y`*~99b2eZLtCa*$=k3v{N9&GEdBjWTpf4uYf8l_qHEe!_MohUtfowmkb~Qex_NXD5Cmwz|x#MOD6SLXRv0Md^Ly~p-yAKg-yvVyPELgGq5P6@- zay(h)@W0L>?zo2cI|KYS*1&5ymYg|Cc&u&P|j(13wnU~QgI zlobO`7i;U=SA0ShMmf7#xvzI#wl+`G5*QyL8?A^q&bMqq^yIH)7#OL{`@@}&YjL(g z1TjEdBSnLQ6M;kgyST>e1hKKQaWu6*I)VovUH)l=8^3kbqM0&lp>|D9IRwMUpgIg8 z!rh0i-d0R8sWkNJW9sDVSbNVsLNVq2E?rln3de_#Pxsv9ythc`$TTWk)z9ugTzm1M z-UT*(o2*?Q$8=>FQkV)B zWm!_JXOdnY6i8bB(xr<9-?&cl@_L8D$9lO#LoOUcBZuV4pu$O;qRjwN%3B4YHC{{j zad>8wiM^j@60nR}mm>M!-n0;m*=zh1y=0;okjZ2ykGCVTkBb|(44uU^BHSMHoUG0m zNV!xG$@FjfN?SlugJ1Yj=%xa*+ zcMsDHIc8bqm_(Mnit<|PC5fvMsc>(1#zu&?(7fmC#3dyc=Td7jbXm)_?FlET-xYoN za>Y3ygSM?U??F!^l+G}=xz7w+D|Vr?a*gU{&JLA#^CE^?L2eqnW6U$CuuN5`p3M~n zB>Y`rZ$U0bF#dDgZa%G@@YPZdx!uxYBRKisFJzocGYWyje2lxQf``||JQcEs+_H*ta8^_8eAXk@C$NX6aDFT_I=Rm6@uZcTZ4;eNw^;g9>m4Pt*ZGe=w? zWka{r9eoUxexBI$I3*r>H5WzoF2# z-$}A$l{71;IY_q{e(i88?EuqbM=@MN9o?S$8v&+~zu-q!(xU-i^z_&yr;6qGh{o!B z7^zJHcyXpiUoi$Y0y_tv7_Wd}$d}{VvN3apW7~PB z8wWgE7ILj|CM}8ylS|h!OphGqV_vl!vFnyVn7`LQF7S1w(uRrD-g!VX57JDN(97pa zi}oo)Jh2-=MtE29eNZ@=NF*n5VyHQ_<)h(Z-;E%O48q)Z1b0Hh)3wAI(v_&u*FTyh zE@xZc^B`^MocVaD^X|~#-6OTmXqt#D|DdFF%%*QI*y=;(-?L@T2($!ml4hB*1kc{F z?sqw+x2y=l^cs*d00jePo8V1%%oh+wk*v0;Eo9yPFaMV zhPN$f@Y{#ci`htrm!6s0rxX(=8|Y)97A?PDgGemg_9eaAAdc2UclUu5f9w{Ua&?y@ zFRA*SJAs_xzK6uL-4{TY0~=eO53JZ+pPbzwK6nCNU}K`T5^XVulejEe1__&=d@>iP zFEZ&zxP3O>ts61umbO@Nivsm51Q<%d_}2>d2YUO70rqz{P1`Nc{!iJWHsnG5axrM@PV9hVjBGEo@k! zy9W_BdgHD|ydx}U(=;mz))8aU3RQ$SlnS_mNu4N*xZ`ZW@X_*_Ezlku2Xv`$Ch_cY8^md5N z#<{J&K(yJ4%vDJ$T~_SbP|ifuupg_PRP15%UW*~lVE2g+uZOjo+3uGL-!Wmr#bKX1 z#2pK98a`;$<{K%8>P18+4835}el@{Jx{h4874KAK0mxI;K5pw!3o#xxCKVKHsp^Z~ zyfOCXSO?9EF$R09D}2gZ2DNW`HT;*Z5Z6~xJkC$;z6LLkBJaLzjF!vGLfzt_m-y9J z?i<10evz49NQb^AP52%7{tFxvwbsvnQA9d#tRoE|w{>7#|4%)S|6noS6>%nE9``^1 zo!A}gMC`C7lEag|VBfY5iVQ_bVqrE646E|JE@eS4$3Sz`NXu`dApUOEcfD3HygqB5 z$frk^42EnL`zVruk27~m>+YqDafRlvR2Zk|BqHD) zq@)bIT_d^rCDQ>d@CZ`NNOIJpvITHPLE z@ibIxB!#zVaplqz(KKbp*iGn-0j4=6F#)kq!SHpYpUCABP?05l6^u#)Ja`irGJo&M zu$u_3zfJz!x_QBlkk>6-S}yQI;GPdDe$jY_o1e#g z)MhpjxA==n3ldNL##9dn)I-} z96w{_!~W80Ed?b7?YX()eywsXRR!h?70o?)>8)s3&){3TI$t4FMn?to9N5Pd#Fh^TL_<0kcz;^$%b^fG~An{15Tt9C1I?blOAxN$29+;&(~|Hk#65lp;TZZ+!(& zx*Zi2kbYo)I|`t*7@)KV;S8l+Xh(9hcd#xX08|1Y2~O?rQ;wMz6l{FF>B-o^6k=x# zc5sGz{gkQCb05(&3&TXjmw!=A8CX;U7+QZ(gq-HOUl)dLTQP=pp-&fw)h6g&&FHs4 zXbAn!G!AA+F*NK0+VyanE>?LtQ{U+K@Lm5_;({UWz=Tfw_#zk9wTI8VWv*Y57EHL; zB>mKU@JOw5EI6LzLjp@xZ9jpTj>vg4tQlv1q;|{#9GubrS8SY7{Ruy>VEiEVKSL3` z+00K`FuH|XL9L3}v(y}KAU^%6VYe#OCU96+K>0mVCl)pSP!0<73kcEed{oU~q>^v3 zO5Ivlir%nn7Q5Aj@KDt2pJ53B&yy$2eA4x^CN!G3qn%rIOoz~4&y?~DAre*a$ zE_o=dSo!N#-r$X#i%kCFkDHnDk|M&teUmcka78c35^A}1dBfyV9&PzV4#GzP75H~t zI&Yh9Cq6*&49xTuo439mX*L>AFl>!VkH=OvZ*%(-snP6Z~1boqjmnB3GTYvSqr)K*92@ZD5xYXN zwhjKvH@?q59%SHGvfK~IDSNN9R#oXuIAn7pGk8x47vFk6G9uZMlBSh-Y%+GiO=x6c zDTwBs3*vk9iyp*G^3`GvtK1g_5VRkeG`(KMwhoTDDb`{VEyc4SW@D3tL2toUmR}JI z2z^E(58lb8GQi6uuxoXct!72dy?urD$lN)T=3(3RBy)*9=Bw#I@eidT{G;(zoN}bx zGj|Jyq-X1+Rdc?|`qEdfd~(-?C-Lxd#JTW#mNV$GGjc=mU$WBWm zVlFP+e6JVXuFqx*;it!5rP|V=+Q2Wm2#7rn7?OW)-e6Bt2WNZm&lm@eYqo7+LknFG zs1MpG3wIev<_aP67$3z5A(ObGkW-T#?m+5664mh4VtIfat#a|`$U@O$C!{I^x&AIK zU(9SU;ea#LGUg71%O-)wZ>L1~7GJ%PX!E>6_pv%$d0EcVH0C>E%_VS(~&zW6Tfd?qyBqF4s^1QxdSJ zG<}4VsldK?om?96MW*a)%YJ(cmubYr2V;#sP}+#(#_T6IrXK1!a=zOii%U{(RypXA z_!u-XFhzqy>m$=h>|kB3%25(H?rNEV5qsTdAZRbhZQ)355q-$iUpL$Mr=Y71n03uY zkn9AJ;o$s%dx=ti528;6&2cK}W9Y zMibd!Wbw3GYJ5U2M^W9SUi#>(u%v=}0znwU#{`0KDM%Z>rtu;cAY$tt!*N^v_N>f!+uX z2kOOoG}utlpxF^KT?L+TQJpV(N!o85N9W-v! z1uA?AFnh#ZK;DpO#%U5vPsoiQm1-71-jF=pmBX33OK(x?bvt>RZYbwPl4z2IxqoWw zGnyR&+}Y7UzQGSXFS-P6=y=Umc_&iTb@=a3ldOV_cgeW5)t$t;ZaH4b*>B!z<#|cV zf_$Yapm7FO{{TZFC{wR;@!p#Dk}X1KHwRYkm;$H0p*o|JOx$SrTXA@-qn$nqBJXtK z7^QU`bQ850?Q&#z^7OQ?{GwkUScqaOynV6|>t)v@qem2yZNZE5wj}U^Wxk+;V^;WW zCtH=kixlI#!|SE5J&NP*E948W7MFIC1s1r^O{LMTKatUU_}-224SS!Qbt1WzSl#lr z9(Vp7T@rNX%M8J|8)|$ibpBF;A?Dxu3l9jcDu$z93qVnHz>ZKUHP7i1U}e{3%id}) z$D@ns+NGFI6ytk-v_nq)=9X7SWzAzWo)t1&&AN=F%&6GKG-7=n^4(rG56w=72+0nO zl}`Re^o#SU%l9W_^(axv64&)^Y~E79p7KM~QyyuV&MV3fU(u)@Dt0$oAb;L*o9*DP z$($F)K{pX;ii&WPzW1~?sh?oQu7#aSQi-uOt2KQ|HxGt50STTfky6QU=4EL$4EW&_T?9PaFYs7sP!fWDo6Mccvb8PexU$c@zK`RuS0>R zx}}%*pS?;iskvqw{lVkql_0+qL-~u5hsoja4XrosPUbdhtx&JZW?Cb7x!typFy>Yy zc{5-BQC6mGQ8)zb-=&%2pEl-n^fp#xdj=b&A&ED8+Fz2l&C!oZO?T5}EBvy+08T+} zT+a(Ve+$alY8wnbsZpfK_`WEaHGwbGQM6%Ty6|V{YvrBq6FTr8+|<14X-ti6=T}xd zKU0i?&>@Pbx6X6VC!|0RLViE%v6k{AnM@&$0sd%va@`$=MB09GuFe~_hO~`Dx{SO+yA8A|lwM!rZ zVHl-_`p|`mzP`pHb5J?=yl0!~M*mc>Hr<=ADm%#2r| zxrwt2Yu-@zcx4uuTz`s~ndS+)9`p)2Da$X52wgo#)vK8u^MviU8)C)%kQ+rBD8F2} zENvF4Fo(-NJ)o~;`m)w>075k6b;9SO6*R=6M=Bk_JCxe=q z$1Cb`^a?)Mi^D^M}rVszDQj^87htaC2*VUTq z@xm{s_{pC1)c%_mke}&Z{KM_#Jdy{y8;^4x9I!{C=$h;wkp|F2?@9^nIW}z&)Xk1i zaT!px5FeWL`>s{gA8hJbe^PKqy^hH<-$TLo)-M>Dc7DASZF$oXrA%>N0;z4aTAX-^ zgqDHr-V?DAl8N|88V`5B`fqLigzxH=NXNzzA6c#Jci9Ul_GPjhRc`2KcPm37BEo|F zDpod0t2p3QB+I(d4z*qEAncykLVQaJN2s`-?baS;pcHJ{snKMcq!vr5Nyop!3# z!_5uJzq5WopwZLAg7mhZKg&FC)~Ci|nV(1w(dOzkwod<_xD3WKYK84k0>JMeFs=jR zFWcegc>Ym!F!usc!m#O)pu*Fo0 zPmi6pi|fFpmrxKT-Za5SE_CwhW%F3exfQQw-<T#J(O9ZhL^6L8F+0dHUllfVnIT=TM0F16o>f%=S?t7X%w8?EvVg1rY^g$&JxaqkURO zLV(sv)00vyfetHkdnBRclJ+9rd|m^yx_QONFb{f>eA4*02cJ_ExV{w-?{zoXP#mFk zuNV=L`sd4gt1frcX-{2N@PtU*8GIKio*T*!_obL}k732iZ{&jxMJkS9Xs0J_tx>ZY z8Uz2`b{1 zRnF1$u6*HKXyN5=KTmi>pvL!^lNJnxwTqFBh)BIdfAY&{)q+Kq0SH$K96iB{*A zGVIgcD=|2l;$oDJ838-(;!qVuXaLBb$;g_xFl_9kgPJTKd@{I%lSO3y-PD zZ_PrL+T27TEgeIgh{1|9)(9~EJO%+r)c?|0CeSguf^!QpFl7(F zQf_Y2Xu09QXlR&sWRAa*p02hKFC~5zNuu5OveAY1ZhA|_=vNy46+6$KT%o{`8{~V| zSOEV@^dWIG2iwQVb#eYl#-PMWNE&0=Pr7ojvOe7WoY z(7hz4B$7-rsWH)jZJDW{R#9$1$Dr;3ufl-GnCu~wDoU_?SW0-_ZKXVWf)$FcCs(!x z%?_WpBJN~I^2AFsKU%RRL3D}7Lc#f?53p)u}bxey=D&db1bNjXT6 zWJ)_pz#>QIQR}5}4>K3kA$P4l{c4hEfwnhq+r8FW@1dt5eH*mN)n+Yug8dw8e;ORS*uvCj3!Ljx|XtOuV=(y4rGZgmjO`AwET4A5|tNqaocU*l90Uu4o+Esg} zSEPpGuX&hoXc!e2zKFlbZI$G*HOojrNMdckGD_TbWE0aF9^5$cf1C3fS}t<%Dr%t% zWPewg;!RAz?8A7ARk1nFfz<-^LH*Gz&N)U7G-p~RqOf~UIc_aqDBIsPxFziA&LH;w zk)&f9X4`7Zj?hFtEi1dhyXAvQ9v%nFP*Tp%*Q)EXW5-ujq=E`qZ``PipV<@OfIpk~ zV1C0xOk{K)NO(#>+e_l_yD`9{Gr!;*x0q+Jj4$osAJUY|KDx!(lAmR!kVcu5rx@zz z=YUYjH3XrMMP?qyc$DH`1&@h-pN$KLj^RBEWw@mUj)nlkplsh)^R;24D}9s&@dcS{ zck6?kgm3S%;plZsqlOAcYSYq!n_5XFObH>^E0Q!PE67a`voC#(EWRH#?-)R2N!}}P z%@D!P`?;fn==69=lF^+~H?cb-JKjgg4L9d6p9eqD7y(83fEX+QF)03@h~Z4&IPOh- zm&dNyq4><}EB5<$#dkE6Y&e5)Ji7Y(9+`!>TfbkKa0O@QJ1n%D+K|ATBB{&>UIHP{ z!$rmCh~-?8xI2z^FjznN<)&#a*%vIIbiR8|&=iA3>gM>5MeRv#pu4d};7T*$>$j(@ zszs8oKw{d+Dd1P08&YqNy(a-i`@XgHmd4+%#wxpUiTYdaQRxyEbUM)V86~ z+t;t3enNIINgA>MS-|KATjsWsAm6G19!*(^9p6Zq;2=; zy>>I^F2=63SI^hwdRg!Sqx)|*cx`hLkqRsZ_y@Nfc2LQU$J|ruT&~(@D(uGRv}lFE7zf)GlG?X3sF{rx`j^ zBGD1Wp^7LWI}@a_1eJdJ6?68939=BSm09auPkOtnqlc`|WR`83#WzFUKOhpbvSDOO zY+-bIVQdLSXM%-ND_BQkU5e4%y^#s!+@nO4Mt0$>Ix2I8Ng$tYTB@qp>Y$5~?VG&X zBIL)Y#2ertW#oPMs`9C^_Cv{vw^Lf=@wMMm)VxG56ZY5THjo(_EEmq*9m$aZz1@U zkNnBK4PP>J6N%|4i>`$7jR4(^7gzSX1U4?#EQl81zxVO6OtnNiD7-)_9NQfqh3s^T z|FdM68?=b>HS5-%^hdbLXcq4j2i@C6pL|RuXJriCo_!qs9I-ERs8&tgsg|y4hj$q( z;mfTYqo(+_B3n6gBacTe!74&gRHOc3uCk%K?Tqqk5YO2=?@F?`VoIfn<(LL0Z3QTC zP3q57Gl)Q3!+W4n1_G?vDfZ6vO!T{2^pwTNouK?T= zR-ch^MD>g|zOp_6V_@F>@F}#Cx^$v;Z;JfB~yA{@Tp{M9`05bDpMd z`T0eKN-f}?HLM!xmDi9{Qt9bA=YgnjM{?xCF1x^Wk{G~{|NGL$)dqIM#n=sM$#?diA|tbWRk>DO`KK2t zkq!!Hw^YH_Ca>dof(@*T2@LhWH;>=f{-KEzym+39b340WWJHb{4&MVv=m5t55c^Jk zjOcp;W{zRM{DKWHc=s@ZicCPaI8D+;UA47M9$D@-CW-x4xtI92U7GwiE*=vd(s#YV zn)qP7+%N$ia>TLP4g2h&XxtJMPg;UN+EP6OC2f9}!J^gA`eeQK(R>(sWnu1?4yci> z#l^jRFQ+uHoNp!41d3kBy`1ziKc^!jvBYSHv8DOzWYj(Z;aDQtKBje4o~k6xd^--) zYVntgKhq10`9f8p)eL~~USKHy4>~yhC8i(DpWlCcA`7gLU5TTXUxZN@hR(xp&r*0a z73?n1xa&zlXz@Nt4UBD}mm4H7jDZ+l;?L9nz8$+^(^HlpkgAl}K&cKgci(*c|V8!#$HZE zG@x>yJx&7QZWNhodC$unro;2%5NcVp6#+zH_HZu+jlv45f^&@oqSR&8YiD9E5@2CO?*m#>0BT7Acp?4wf$h6{ah{E9 z;C^9P9}i)s;XyehkmehOcML|8365rtdXCxhAv2G9Xv|GaVe{LHm>%!Ye6^V_+-%;& zPc?W##UdFEAG_3$G;{L>-OWNY#4J85B!$A^7}*trs*YeUv^Sxt)&b1@{Is=>z=P}z zR`}V?-1S@~kM>ue4sT$`U-(wZ;hc_=9=}GDxSeN>|J8RKql9N?3s>FoRbS&zjluYT zrW%h33omp4|FBIpf0=X6^Z!F*;Qs3vFF;s;1j0R1cP`Z&vI>P=HepvaBVo+z**Qd2 z$_-a+B%ETydO+aVPj`<{iQHadcSosU%<;Cy9nL=G2D7bpWj@VmE2I!i(x40MB~LRk z^F2@qXwiCiMI&&f_h>lQbXW>!!lV0()GK;Rya`^#etA^8up~^EOOU-wCBzyJD4h{`$3`P00E@HQ2yUd@q~yUsyOW}{|h~fX9*Hy z+|ubme~B9b5Q7Wwq4~c@Uv6XAmMhpViMg8sKfic_!cTIbLliq~AEoqe`W$1AG&~Qr zWAo@WW=HzqD+$&4>EyEFXct&(4tISRN&A9hN*BGHg(Y?>;iG7|6!VJBjq@+=TnX#a zfw(+cunW2fHM{2c$XcjRSxCj8eO&k!?bdB|{cSzxIloe^7d0qv^pY(~lO(!EaI(wa zt&M?I4&(Me`9?hN9{6%S@euvIU5NL}4}}2|Km#No1-$>Icbx3{K7}5JF@iX-J)=HZ zX0mwix%dwH5?p4Di?L9xp9&|S2WM~jyd~>OlT~tU!+G>6W}HKGa+F4d4@#UQ!u0IX z?YAONJq(@2oTG^<^&qLZ)0Q!JFGRsZN|v?-y(=r>++x!%}r4(W@oV%t^o?j5T( zzjj=jVag6`OuqaAeh=o54>&i9?0wGcxPaMS-Z0u_*xd|ffYJW}3!h{3jOoF!uwhIs z#tShtsjqVTVe#}6y7o_>U&|R~)Ivt!IuL&5E_OM2`PJTAA>UL^0{@qo6LG*Njj2l0mge~rL#wo#} zmL>cA)H;BG?k%aF=j5%FcRC~yg9(~E;xk8$oRaTN1t$^R;B|@o(wBKjm)4X8F#TwS zpfBoVL~rqy20G;C1RYE->0Zq4$5-!4k&Rr~kiM5W`GI&R7XAa-``l0YA0DsVG_Mw9t zJ4$BRkoKYF_@b-tMi3Dfn`W<9cSWL#xc}loi(^*!Q9?5AKZuhiDq<@I(>qAWHcJ zny+{i)U>hdf&ubw!udCgH(efUG+{bqzn6h8Ax|0;%SP8*O==1zbTg;K%$~u`jvh~5 zl;I0!9ND*cw2`Cc>?NJ*c8|uYM1PcZjv2x9f?A86uC|O_6zSH}aEbSVN^t3GnG9%e z?Btq+h%bG0yJvFE*k6y^+m5Z4?w%9zmC7ks+dizw#VKqj+CaP>VoL-LYVDc+xUxmg zl2BE?=&Fg}614czS;U67L7FjlZgA2_P&KxIKM6LR{75dwvfUdh8~-+~?hOU{B8twDt~+j> z5?!t2xRS3pWfAg`^js0+J^jtfQ~h6js}vw0o2H z6zW43k)0c&eHedg-T4Q7sEuXH1+ zmZTxJKAnPV7EA1rYYKUfQ*W1y+|-_9f8O>HnT1tlkku>Ul5EQBL5|Bk*$>LK>zkbK zL2wtE!z={M^`}+)lR1W{w6gIQqaE#e@QoN%$$DCxyhFc&{nO?5viY6Qw4t+DVIfDASCCo)lUbC#sxrwEhO496 zqPOcR1l5{V1DAiF>=X zdg1XtJE;)gxBgeAXbI-Krj_?AKi!^~K?fsl(*)*Nzzd8`HWf3OHdJ0a6J@_H$^^hmo}Re*Y#fLMmue}d-qb4Gj@vTYC3!~Ytrjg zhtDkBEzE>o^4&Dtc+!L0Wnys?`Zi&5d;Dl)$i1;oTwht;xV4G=Q0b9v!_NIEWKIDo zg~#OHwmlcSLK(F!R`BoP^}gfSuyeM47w}F6Pwk?%0%|n#9xbweMWP#ICz z-0Q>nqOL@4^yhoH4zERNSSI_NdLC;Iyxh;=|Az4sWWb_iy4EE9C=eyN(Es1`R{kMM z{s`x%crX9Pw8{bxmLCSrQ45#F<6A5s&z=_HOueGy;*>CLAN_^v_4XJYy<-?i5?`Nt zw2RJJ+(FGNGr?W!;{=|r{hV4Q2s~X&R@KkxptldF?FL^{I)kW(GNOlGSyA_4{o9p9 z^tswguM}DAhWd#u4>(@E0+r}@X6ZV#T{dklkCAL)`U>@igeE?|GEqssX&}mfS)wV{ z(5`kx_f-aAm;Y_;oR{0tm4aCMyn1#wXI13xPfCo4Y$GCv7Uo2c-G zgMQ*-cdXX;;)Uo*>e+opY(4&C)x@Y2xPDaC+|P>NvbDG@)yZKfzSO&L=SHxuhEXM_ zRmO_b8Z)k6pvh)KvF){MOK=h8-AFt;sh9aU;%qTixED-`adVh)y36YxiI(csYNgte zrm;j8>#qA|_F+X4kH)7b+A7dqqs33UUeYmf$9|8q#7vAOE0KDCr*&`GS+ezWQ^=-S zSB-+J_Ikb8Yj(U2YT<#Aw1_W_<5%yddG&HMf608q9vA4@FhSVMa^bVMaZ>$J4;k1q zQ#6p!NfQ3*DpIwXeJ(tNinVk7`ZmViQciD%`OWr;8iNI%Cucm| zr+=>GW}G9!6-7cp{IPFub+h~db4cHW?1r)FpPL#cl#hPDY`91_U(?^rBAhLU6eOsy#@{1AGb#> z1VL#TKZi1ZBvrZTwP3nJ9JgGFHkIO~ndrk&I(E4=apXhnRkp5yfQhk`oJS$W6h+iz zRU+hpna{>9uL=2GH9jz8se`8`c&-&Gy6q;kvS|X5?iBUkOAG^N+CT*!FGd8C zO%6Hcr5yoJ@~#p?;}x7j(J|@|*$JuKg;&UPZ{_$2;1vo&D?VMf{xG6yW)wyq(NFj? z+SaIFgjkx=y=0eGglX+b+o&8t@4Go2>D3j}Vy)$-rx0y1S-MoYd{4!)DRI>&yo5X9 zC>Zzn1t+HbXOSp!AKIF=F}Gi^3W}N$^jmK9MT(SPKlo~}eke$;G|Ch2u$I-jKJ|pE z`l)h1`ji_D-$QtYD5bd2UEcEI;<%fyd}62-p4MgrImU_~QOD&@dwxdXr&#&=wb#=n zoHvUr@CiFj)X4k1*cT)ej~0@~=zNwQJns(7X-0|x;^!f|;O56D^=o!r7}7ZCzI0dc z4pLUxiH~lh3p7PaUKEFaBiQQMGh~YuZJ>u0u}`pmv7o!-6;DA>`y7~AZWpzIBi90- znzxeJL)L^FW8iZMf)x($J3ArN&v0P4FQxm*GMJI?5IZb4lshIn%F-I&(LOEk58j}8 znl;@^!t!+S&DZ^vuIJ}NsI`C#~t}#oft{n4jNNXUk=qg&qx{0=FLYtzF(}EoS9zL@Pv1nWe>5=;xTGFje)n& zaUm^Iw|MaA6|llDm6BR6eEyb65S@!Mu^4)DMYVa3rM)%&`jtc~FVx)j$D6~Q|4(ga z9aYuxHsAw-ba#Vvr<8OE(j4hjkxmim4r%EWkQR`V4y8k-LAoTRyFvI4_uk*-fOx~} z=UPV={IQ>TXZD#rd*+>I^yZRV1^3YHFleGZ)GDJ!Z!Xh`;?zGxKd@PF82ysx%*}^# zQdF=klN&YOSfnoVTG3z{Y5jp%ohkO`Te4vZmc6VdkB_-E=~Pjg;%=t$WIyN~8-_0# zEyQ0}f`YD1`P}cTPxMF|I)b`apKiQlcR`M(Uqmw>B?G>+8Dlp+;8r_+^Xo^1bo*XW z?R&eM2V6a>HRhNfFG=p)+fg9`|nc?qDzuMsYR`1eM`7^n^>Wk1{T3wR(Lo+ zyTV8Tr|j9%y{AEZ;lUJ2=5sG-^IxS2-Q142J-Z$JAtjEpxfD49`2nE`Cft+c4SJCh z`$%&b`ra(nKxWnLwwLk>3=?j#UCBlf5_vZK#{#wQl004*Z9DAEj2=6fA3z4YY#wY| z4zY^mi>7ZQR*+4_@aXgvGTnPJROGCJ8Kf2cF2B^_SuEn-*PZhD9?`DJ%&xoh*(xcd zaZ{vAi)!2v^N4IIehjxD+Swv{_!^)}(860nrLyYNts1HrP_&b#5IRx@X?KA4{rI(k z8I3OHizV4g)^7_|EXG@Iv#6Ff42_+lwF)u$dG|W&#$^V_OKS|kYIC1)rs*bhnV+f< zJ%n-2sFZUa^S*oEU1m7mrCE>Fud>L7vb!VHz+Qo>{0J7EJW3(_&^l|&g5=;B(K8@E zTx%dBYouXWZE=_0j*VTH_J9Pq(R8zbc+#{R`-D-h`2BtqlVV!qsa@3>*bDLbfaDD6 z)!YrxQme&pmXE)AZTr!;>Cb`4s_LXEXr0y7mh`MKY&Sbp_$ao=7r8+t+P3g{aF}

)WiNG1kO{3RRdgDrXBLK%46+{RMP<@$ ztAzQXZOr@f~Np3kbRQpFopmwgSF(mTTEtrpl7YPyocB z4=SHus?4Et(InEb+^FXDVma1%O6jez^j=q| z6N9+7Ret6vo0iCVgJHXm$lG}MGLBl8k1EIw)#l>Ae9E0ifhgkRTt*Zo_yRwr`y_$^Lt1hFykTneAX3L+y7;vC_n09h`0ZHCI0 zU&Y+dMWp`EX+as8j4`6Lx}Gbnn!?|H}?Vz@!Cd`6uk;0set!f!I` ze@wT*CB7ZuktP<{5%S#PE6&Bk3I+7_3ZJ7-KA*jL0{Sri-L&fOUoVqCvlf1zFTD>0 zg1iy))47}_%5;*9be&!IdlgxVl(*IXsI9Ta)^{oHQ;sDKk z{ZYcXe_KR`c)md3Ht_8NYxiv^6LzS@skwl;OEc5wg?txQ<8}(_p>BZIqgnr1A^%K1 zxp>wms>oW7aia2r+-juKLljwNLlQ*Rh$EsNsU0ak#kVWa?eb!8VTD_p;U0t3Y7~^K zBQR+iqT#-cT$Tdafd#z|8~Y87G`Y*W5by9XSDYw`cJT9a<7~c~3r;}CbrUT~BdH7k z%QMsX8+^=Fs_r>VfXr&k{p^dL7+&6T_M6hK9;SKm_Je*)y#j3Rz>V#i{odfzC^NCP zS2=@5n~j|ZP6|%ZW!NCI+Q|Ao%Z_}}jb0HtsE^Txfno=GN#xUB+>#XgdP{jwlXN9B z+gfSBLTVBp&rGr>sPATni$+k=-X;w+c4i(%8iq9NJ$h}m-bbU!Ty07d5LI!z@c{>f zzT6Qmp327}zB}{wo#stqUwuNY`VtK>4(iJa98FSSoq@*`Owk z7rnhi|HL>~ha6~9NOkT}!CtEB#$vclnM0Bx4kFWv-6pn(no!=(2uEHIzP2x$g%m2i zYwSxofqL_i24__Y&qMD*pJhhqd8FhoH1}OsnPz%4S6@kdp6IgBpYfhsa5khubk!bw zHHF}V6-S$m@*!C(*KBI5>rD_6&n5a$&Fnb1rOr+t&co&pEWSn^()h@nQ7eCFB z8GAIF*oxPk2JB=R(q^V?EAejN!<5KO((lzk6k|2cx3&yrd>%n-sZ(!RL2@HZmZNkE zn|s~{XCS~((xscdxsFV;N^gUoXPmB2Kmq$Eg)-GQly^sHOBD)AXP^5ORL2LG1~ZS| zXP?rQrOXwrc;3);cHLL@*7ndZst}px`=T{t)}a)5W)3o*eT9-h3`7+nl*U*@q zcE~y?O&0?Z_+)ZMscE=)+Gb277$Wg5&CG)wyG*CM&QQ%&1Wl410hx3y**YOE zzWt;mel8@!WL`7=Huu+11AKe26($*KsL{^&JA85~CKF;AH0qd%gauP&#*h5+2r1FC zrjF*tzRs6+))pgUtV6DcGf+=YDa6V9*}P*w=Uef%)(RX(OSiVkswYsT`Aiv~oh7bz znkj7!MM9G{_;OmCWpNuI9ae{pyLD^&T^m~N*Y_nKF>2^pU)XR zFP)FY@$-i5gfIrV?f!?OyK5`&f_2fTYd8E<7DqehT6cZrsH1kQzhy_9f%!qsdz7eI zB4ISpB#a)YN8tr^eSbMs{d>1}xkvePypsXyRc7uY^0&F4-AMVcv6d92_QG&R+#hb!V*15*+@#b(=ep6TE8gQ zkRN4~qHLwNlZ)@yLn6AXZ1KK9^5Yr&~hCzu>(|Y_l|TU2%x#!!e}1{Ar)dj zd>ApYyAY1%ro|MEP;^MMCwbtCm?vyiN+JIu29x&Ys{;xOB`jvB`eo}d**5b*(-}1~ zv-}+Sl2Zy9`m%6a!F{zmW)@^!U$->u5>+Nt40@U|p)(lLM#D}QT1|uYQ*bbIiMX-u zZ*{d5Y5}z0`ECF^xYZNxgJ$WG~h6JjXM@3|3`%Fx!e;e#QwK#{|rLPNzxP$97Dzw2#_ zbjSPw12P9L@3es#QYSwDHY$X1S{6#7o=!(1lxIS{r(jTiPg0q_c-Y~%ejGLMEe3P7 zAyPwHW36z+jZVJtbW%O1+tLD6%q25irG3TtW0-KdxgO6rNHu`)ijVPjCrqa@;K>F< z4q2f>^^FkqDM%s>Yx}(8ww62!ChgUZZIRRldPaF|T6*rYw0W~mLj&zfh>gU;Wo7#+ zqtgm9@<}Qwh{))BpQE_$l1Dxv)BScozskDbS^Jwto@;@M+uX~~!RoeifuU}$`%$gt z5XRQL<#T}|+g*be-sjU3C#~YI(StL}8>68L+>*k>s3NvP!i4+={Mw`^fFc}?_FZQ=Cs)@JZFcXHG9n5vHkvg9emG?9(_8c ze0~!qth-(-onnrocXsJr+F52GF=&3mpxKhjqrCp^LgJc3Y);R#*prhdQkz!t#eUDp zQe^LkZSs3V+{NaKSc-m;9GBFmNH1j&kA19JQIHdB>BW!khiHzd7y1$ z`@DEct-CAkp1m+5=gQ_mVKF4mU4d{e_)Ine0;Bbo z$W>#CI8Pa-1^i%pE}QYhCd$-m3DXfoIK+&m6r=iJ3xt7%=$05Q!|WyP$@$n^MgM;9K+` zz+E18bL%LJ5P>SaAN2X#9FM=L_&+=Q-yCV@_20yT=(8W?2vcl|lTOg&iG(hq1z`GO zJnnC}^|~ppbBx&VL8y@AVHn1tQ`dSUI&R9X!lE?DXf}u?VrPbFrY`cxz)A5|c5dWW z$i@UXAM7ljMq*+TTZS*5DeS?dn>fKY{NTm-*&;t3=^t6ph&>SR?c<0Vwyt~6PP_dv zSw@%&#|DpnA{eAlvO|x7b+JRqvn-~0z)A@(j$i_>^&r^77(aZOLHXPAC?Uoh`Cac0 zCw|fPjc9+J3Eg_V`ivWEJYlFNDwc}I4)RXlBQLpx3$ ztPzUX)iWZv*S&6n%nm~51NXlXi2mV;Xa3{o9|QOET!Ph?zgghj1vP7@lQD-7q9KV` z%veHE8u88Q<86Ku!NUfLjf&~_qGeMgf!2d(0tuyTSB9P?=4J>Eu{zjchIB2yD6vk@ zQbLF7GGxJo&SHh86aaRfQU<^w1H;f<;DQY<<<+d=Ra)|BX>4I%(E5^(wj!^^b{A1n>?uwU92-I(?P41{JJnr&C z@ANihHF%LpnO{}56GvN9{7Njk{Uhqb@T>D4#QCcPp``M z#ifTh)F=#Q)Tubi^2~FK`9EchgQGj-g3lHqSU_m^j@?-uG!~9x#B4&vV2t5l#Hvoo zQd$}_WrRdd)qc(<8r>IjhaAt{IaA1@>22bcnTm8_sD`R_Wu%dPg#N=^Q;L0HfXBT+ zKnkoAZ!Wg}Kqld$*eK<&;}S8TbF7m4qa8rLPvwmhrUe4A98$5V`}%N0`2q*#1kS;$ zmNefPsDdCe;}_Bn@(;%Q#1tEBgW{YtUri=9vDeAx0L?yp?zOnM3^Lm!ZV`JdsvoOCT&rUtDdTQZ(i)hu5DAKL)>W8f@fb;Ox0Q=bLJ-sLhO;k z?whJ^Ra>D$0jy7*aA;s7s$6GtmCXI5AuKaZFFb^wtbKi(FZWwY{jKkGyM^1Z~io@C)_y=N3kKoTQLgDn(=wORIP zO2TJBt>|_Q1Km61w)6op%*}Og5%BYY)vak32anKQM7ye7_U<=EnVJpF^I} zAuI6{Dc8Q|7ZiNIKqhEF%ZUbcu!R=RP^#=Slm8e!d=V;9qfm!yu^krQ-o!TOJ&Yp6 zdg+6CWVvbXfySnz**A>Eab&tPWUnhm)3$hP#OauBW@p)k*5&PNR89%)WBt>_fQx9ip{)kRKC1ewo#T@u+Ub@dhA3 z*bV_S6L?ptdv~gS?Lr7dgU@-jWh1NS!H7j$xyQ z>d<2A&z0DDG#4@(^Gf8MkNvUPW*KLQGIrhJSAQ1fk}=DCY5#mYQ`b;DAFOPoJq!m_ z5oYg+dQr=;wLL;FQ%}^yFxVtN%_Mu@;EoFRtxP*%6;@%-NE&xZ+#*P2Be@Pmh)-#( znxSj>E*-bG<)DvGQixqtYBQ_ZR77cf6$BJ$xQHEh8XTG}rCyPjvvsn*GS~}CRb|Rq zHZ$h!=-SR9!RlL)o#jDPFO8&HTC8$kKtEzLG!J_{{9UL$e1v0pwjOVwVP9{cNo zJu(-BlWBMSIGu^8INyWai1pOS&=>cFfih;VgxuUn{48a6RXtP!4(bLh#=#?w2>Tn`{7e8cC*oH{!`QjQj<@wTLy)Z&Lg`A>d85b;>2 zWJFbJ$CR2&PIyei_`;pUTNsr)dANH9ZHW7Ex6Fn}WkRL^tXzB~3Q(cwVYD7Si%M*Q zC&ro(YZqJ6x}>(GQW?2ATWObVPi~Ou+Qu@dZwL}EhGkF5k;GDBaU!;u6B;}~G=XK4 zzK7R=Hc?naRESR5O$dv5(%0Ac`BMxeRZYR-b86-4YHi;G>k;EFXf(*}^yfPR$7Ww> z&v;Dj2r^%?MLso5-@+pPb_=%G(=hDV%Rj?$Et-XS+9ly2r&fv6mQ({hzzL$Z4}%9g zBfRve{P;yKLN{iKG>o(5gFZW3x3hQc7+irloaXVAQ zg!&~5JSL0Am(53zJC3fkTDf2AfPqNxIj$ZKr*})&o#>lGyaewp5c_R@u+a^H!lN^* zB>_vT96cZIOheTJKm!(QXaL~c>iE~Q3cnwV^S|Ma?$amFEN%YCeN!4W0j)~9Ocvmx zi^h8*IAG1Dpo+?lL*a|k++(3Pe$1?HtiMWA%DA(h*xwwT+X6QXV;slxbl!I8sfaYT zOlmo59HNnr&^$CoX+*jVWb`b0t%ryo8%8nnz)AM$r~EH%y5jT^7~I5B48l~Ju$1?t z)rl37$c)HE_q5>2fOzj%h#psTVpY?0Gs*dhwHOTtx)%VwzAEc0KNkVKx*^n@{qckF z(u1yJ4Kf}5%=Ch|hY^p2aCPd3)h97xx#y!z?%FY+4?cP-%Q%p@1cZNETg{=|icsB& zG}REJ0cj|FBM@6UUt_R{px=k+RL!`Dq6^!aylP@_C0f@dYYj_C-Yu8(yC- z;NnJv@eqNuV538Pv7h$*SsamaSN<&;LR>3tr?#}6tj7mfhv?R2-0dMqq^#F zS&Xip3`&aL!>pqpX^H!GTX|v)VU!?)ZUnPE)W*(}AsCS$W~%Q?_81YUJ-+>N;>>+| z-a_Ej*h#{PN2=ANta_1Ez_5+L;Ww9?;V_PO9AafHsgud~kZznjY-;4kRHz}S$|K)j z2%#P)3V$cAD1hQ5IB^J}_@*#!Zj4_&bw$8{%!Fb^z)<7_>=m*dbgoj3o5=?_P)D-^ znyaGv;a&B|sQLF(mOy6>=BbQYjNV0c`Kl_@0cji={=zHSD2kNp4)n*& zph2a5M7xPPHhswpvvk*)v{-IuDov+ffT6 z5qRhc*nxBU9cGIJ(lOS1>@v|d2*MAfGgYKnZs`Usob=7z zx8FQzZbOZ*TmN#CzZrl7?AdnG^Lzbe3{cHa?4%vlJ6O97G4^+MjvZzk?rKzWYSQD_5qEOC8#>QtFuxUwX7v3U6yJa4!dpn+tpKSohwg+pn*WTi9X{5a@a-2zXL|9@>806X<&u)bW(eZk@PAX*2h7!61Qf{%5as))57N(5Q@DC1EwWBih+=y zq}1@@qp;f)CvFyunqwdn9j#Ty5qCczYGx+fePg)4n6z1kp7A!!{L>Y2P&-aR7*ptynON9PFwjd~eA17()UL>E(JfuFTm(k){w^ zOXtruiZWyIp<7ia(=2K2T4$-2Iz1iu>YW$idPkpt`35U&mPdyhCcdg4Ez ze`poI8u?|LI5=Jv`{yISg1_t*zgmRLCUEc~5aawm72(>}IG4R#R(OM#W%K9Daz!)^ z9{)M>vd$WusgC#4@n2zH8}Rp1XK;8o{!hcfHEQ6|elIr$2l9Y+e*WZ_`;zJyocLRt zUQ!i;6UQljns`a#ca?Zm6nMexq5L((YuocWP2UB&6ZEe1lhymDwC`%5m)(08EC9d| zWb*hAv`Z$wtJKRTGjM7M-LIowTgB)1(`6wPIKGwfr}1EVsH@>#HZOtmI+=b2@7h4W zw;O?jXPAE){704?c#zjQjxK2TSbmyy*?0twJhy9H7T{a}0f1L*{{eZOeda3qs_Nzf z&cgnS(bu-__fDIO5&!^gKVOC`hMTK#Ul!VcGetOlI_~ckGgq;fT{hs@nqP^%wyLj_ z*j$uA{Pxd>eaY%_HRQ|cm=NBP=817|R$ORby$N^;z{>N~C zw{~0&_p%xU9LWq)68{q9wc&nm0Rd;%{de}YPLQk7U$t;tl%av|r=!25s<=wLti!nA z0RV469)q8(?@PpMtNVK!1vvUONd5HR(BF3*=fta4i3_G8=jV)OXb7Qy zivGbyXz(WeewXzH2mqi4DK-9Cls`cIFucp#62X}!Qh&qzJpt{~{OWhpo!9Nvx`0%G z_L%%-SU*Bs8_s#^;^mDi7bE}x2jouq2ds;2Ea0tke(B4*PQWi+`Y$ehu?OYq^)GK2 z0l&Tm=%l@WQ1m~ipTBE`>$1l$0J$nZarqy%z~$u83km>$rTLFIKTIXPT49&7CBaEA zwEi3E`ry9H4FpGG==>e>^3wTtZS;ML2KeQdAOE|{f0wWUUU}Co`(MBy4gVzyEC~Rd na@{iU1w{?y-@E>vzPc!^APo)5#ysEhzzaYG&39#(pa1rM+;^tv literal 0 HcmV?d00001 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textblock-0.1.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textblock-0.1.1.tm deleted file mode 100644 index 94af61ba..00000000 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textblock-0.1.1.tm +++ /dev/null @@ -1,7226 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2023 -# -# @@ Meta Begin -# Application textblock 0.1.1 -# Meta platform tcl -# Meta license -# @@ Meta End - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -##e.g package require frobz -package require punk::args -package require punk::char -package require punk::ansi -package require punk::lib -catch {package require patternpunk} -package require overtype -package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? -package require textutil - -tcl::namespace::eval textblock { - #review - what about ansi off in punk::console? - tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ - tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock - - tcl::namespace::eval class { - variable opts_table_defaults - set opts_table_defaults [tcl::dict::create\ - -title ""\ - -titlealign "left"\ - -titletransparent 0\ - -frametype "light"\ - -frametype_header ""\ - -ansibase_header ""\ - -ansibase_body ""\ - -ansibase_footer ""\ - -ansiborder_header ""\ - -ansiborder_body ""\ - -ansiborder_footer ""\ - -ansireset "\uFFeF"\ - -framelimits_header "vll vlr hlb hlt tlc trc blc brc"\ - -frametype_body ""\ - -framelimits_body "vll vlr hlb hlt tlc trc blc brc"\ - -framemap_body [list\ - topleft {} topinner {} topright {} topsolo {}\ - middleleft {} middleinner {} middleright {} middlesolo {}\ - bottomleft {} bottominner {} bottomright {} bottomsolo {}\ - onlyleft {} onlyinner {} onlyright {} onlysolo {}\ - ]\ - -framemap_header [list\ - topleft {} topinner {} topright {} topsolo {}\ - middleleft {} middleinner {} middleright {} middlesolo {}\ - bottomleft {} bottominner {} bottomright {} bottomsolo {}\ - onlyleft {} onlyinner {} onlyright {} onlysolo {}\ - ]\ - -show_edge 1\ - -show_seps 1\ - -show_hseps ""\ - -show_vseps ""\ - -show_header ""\ - -show_footer ""\ - -minwidth ""\ - -maxwidth ""\ - ] - variable opts_column_defaults - set opts_column_defaults [tcl::dict::create\ - -headers [list]\ - -header_colspans [list]\ - -footers [list]\ - -defaultvalue ""\ - -ansibase ""\ - -ansireset "\uFFEF"\ - -minwidth ""\ - -maxwidth ""\ - -blockalign centre\ - -textalign left\ - ] - #initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only - - - - #for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns) - #ie only vll,blc,hlb used for cells except top row and right column - #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) - #right cells use 'U' shape (vll,blc,hlb,brc,vlr) - #e.g for 4x4 - # C C C O - # L L L U - # L L L U - #anti-clockwise elements - set C [list hlt tlc vll blc hlb] - set O [list trc hlt tlc vll blc hlb brc vlr] - set L [list vll blc hlb] - set U [list vll blc hlb brc vlr] - set tops [list trc hlt tlc] - set lefts [list tlc vll blc] - set bottoms [list blc hlb brc] - set rights [list trc brc vlr] - - variable table_edge_parts - set table_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - middleleft [struct::set intersect $L $lefts]\ - middleinner [list]\ - middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts $bottoms]]\ - bottominner [struct::set intersect $L $bottoms]\ - bottomright [struct::set intersect $U [concat $bottoms $rights]]\ - bottomsolo [struct::set intersect $U [concat $lefts $bottoms $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts $bottoms]]\ - onlyinner [struct::set intersect $C [concat $tops $bottoms]]\ - onlyright [struct::set intersect $O [concat $tops $bottoms $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $bottoms $rights]]\ - ] - - #for header rows - we don't consider the bottom border as part of the edge - even if table body has no rows - #The usual-case of a single header line is the 'onlyleft,onlyinner,onlyright,onlysolo' set. - variable header_edge_parts - set header_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - middleleft [struct::set intersect $L $lefts]\ - middleinner [list]\ - middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts]]\ - bottominner [list]\ - bottomright [struct::set intersect $U $rights]\ - bottomsolo [struct::set intersect $U [concat $lefts $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts]]\ - onlyinner [struct::set intersect $C $tops]\ - onlyright [struct::set intersect $O [concat $tops $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - ] - variable table_hseps - set table_hseps [tcl::dict::create\ - topleft [list blc hlb]\ - topinner [list blc hlb]\ - topright [list blc hlb brc]\ - topsolo [list blc hlb brc]\ - middleleft [list blc hlb]\ - middleinner [list blc hlb]\ - middleright [list blc hlb brc]\ - middlesolo [list blc hlb brc]\ - bottomleft [list]\ - bottominner [list]\ - bottomright [list]\ - bottomsolo [list]\ - onlyleft [list]\ - onlyinner [list]\ - onlyright [list]\ - onlysolo [list]\ - ] - variable table_vseps - set table_vseps [tcl::dict::create\ - topleft [list]\ - topinner [list vll tlc blc]\ - topright [list vll tlc blc]\ - topsolo [list]\ - middleleft [list]\ - middleinner [list vll tlc blc]\ - middleright [list vll tlc blc]\ - middlesolo [list]\ - bottomleft [list]\ - bottominner [list vll tlc blc]\ - bottomright [list vll tlc blc]\ - bottomsolo [list]\ - onlyleft [list]\ - onlyinner [list vll tlc blc]\ - onlyright [list vll tlc blc]\ - onlysolo [list]\ - ] - - #ensembles seem to be not compiled in safe interp - #https://core.tcl-lang.org/tcl/tktview/1095bf7f75 - #as we want textblock to be usable in safe interps - use tcl::dict::for as a partial workaround - #This at least means the script argument, especially switch statements can get compiled. - #It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp. - - #e.g $t configure -framemap_body [table_edge_map " "] - proc table_edge_map {char} { - variable table_edge_parts - set map [list] - tcl::dict::for {celltype parts} $table_edge_parts { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - proc table_sep_map {char} { - variable table_hseps - set map [list] - tcl::dict::for {celltype parts} $table_hseps { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - proc header_edge_map {char} { - variable header_edge_parts - set map [list] - tcl::dict::for {celltype parts} $header_edge_parts { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} { - #*** !doctools - #[subsection {Namespace textblock::class}] - #[para] class definitions - #[list_begin itemized] [comment {- textblock::class groupings -}] - # [item] - # [para] [emph {handler_classes}] - # [list_begin enumerated] - - #this makes new table objects a little faster when multiple opts specified as well as to configure - #as tables are a heavyweight thing, but handy to nest sometimes - we'll take what we can get - set topt_keys [tcl::dict::keys $::textblock::class::opts_table_defaults] - set switch_keys_valid_topts [punk::lib::lmapflat v $topt_keys {list $v -}] - set switch_keys_valid_topts [lrange $switch_keys_valid_topts 0 end-1] ;#remove last dash - - set copt_keys [tcl::dict::keys $::textblock::class::opts_column_defaults] - set switch_keys_valid_copts [punk::lib::lmapflat v $copt_keys {list $v -}] - set switch_keys_valid_copts [lrange $switch_keys_valid_copts 0 end-1] - - oo::class create [tcl::namespace::current]::table [tcl::string::map [list %topt_keys% $topt_keys %topt_switchkeys% $switch_keys_valid_topts %copt_keys% $copt_keys %copt_switchkeys% $switch_keys_valid_copts] { - #*** !doctools - #[enum] CLASS [class interface_caphandler.registry] - #[list_begin definitions] - # [para] [emph METHODS] - variable o_opts_table ;#options as configured by user (with exception of -ansireset) - variable o_opts_table_effective; #options in effect - e.g with defaults merged in. - - variable o_columndefs - variable o_columndata - variable o_columnstates - variable o_headerstates - - variable o_rowdefs - variable o_rowstates - - variable o_opts_table_defaults - variable o_opts_header_defaults ;# header data mostly stored in o_columndefs - variable o_opts_column_defaults - variable o_opts_row_defaults - variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap) - variable o_calculated_column_widths - variable o_column_width_algorithm - - - constructor {args} { - #*** !doctools - #[call class::table [method constructor] [arg args]] - set o_opts_table_defaults $::textblock::class::opts_table_defaults - set o_opts_column_defaults $::textblock::class::opts_column_defaults - - - if {[llength $args] == 1} { - set args [list -title [lindex $args 0]] - } - if {[llength $args] %2 !=0} { - error "[tcl::namespace::current]::table constructor - unexpected argument count. Require single value being title, or name value pairs" - } - - set o_opts_table $o_opts_table_defaults - set o_opts_table_effective $o_opts_table_defaults - - ##todo - test with punk::lib::show_jump_tables - how? - foreach {k v} $args { - switch -- $k { - %topt_switchkeys% { - tcl::dict::set o_opts_table $k $v - } - default { - error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - } - my configure {*}$o_opts_table - - #foreach {k v} $args { - # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. - # if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { - # error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - # } - #} - #set o_opts_table [tcl::dict::merge $o_opts_table_defaults $args] - #my configure {*}[tcl::dict::merge $o_opts_table_defaults $args] - - set o_columndefs [tcl::dict::create] - set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row - set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly - set o_headerstates [tcl::dict::create] - set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight - set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data - - set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices. - set o_calculated_column_widths [list] - set o_column_width_algorithm "span" - set header_defaults [tcl::dict::create\ - -colspans {}\ - -values {}\ - -ansibase {}\ - ] - set o_opts_header_defaults $header_defaults - } - - method width_algorithm {{alg ""}} { - if {$alg eq ""} { - return $o_column_width_algorithm - } - if {$alg ne $o_column_width_algorithm} { - #invalidate cached widths - set o_calculated_column_widths [list] - } - set o_column_width_algorithm $alg - } - method Get_seps {} { - set requested_seps [tcl::dict::get $o_opts_table -show_seps] - set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] - set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] - set seps $requested_seps - set seps_h $requested_seps_h - set seps_v $requested_seps_v - if {$requested_seps eq ""} { - if {$requested_seps_h eq ""} { - set seps_h 1 - } - if {$requested_seps_v eq ""} { - set seps_v 1 - } - } else { - if {$requested_seps_h eq ""} { - set seps_h $seps - } - if {$requested_seps_v eq ""} { - set seps_v $seps - } - } - return [tcl::dict::create horizontal $seps_h vertical $seps_v] - } - method Get_frametypes {} { - set requested_ft [tcl::dict::get $o_opts_table -frametype] - set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] - set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] - set ft $requested_ft - set ft_header $requested_ft_header - set ft_body $requested_ft_body - switch -- $requested_ft { - light { - if {$requested_ft_header eq ""} { - set ft_header heavy - } - if {$requested_ft_body eq ""} { - set ft_body light - } - } - default { - if {$requested_ft_header eq ""} { - set ft_header $requested_ft - } - if {$requested_ft_body eq ""} { - set ft_body $requested_ft - } - } - } - return [tcl::dict::create header $ft_header body $ft_body] - } - method Set_effective_framelimits {} { - upvar ::textblock::class::opts_table_defaults tdefaults - set default_blims [tcl::dict::get $tdefaults -framelimits_body] - set default_hlims [tcl::dict::get $tdefaults -framelimits_header] - set eff_blims [tcl::dict::get $o_opts_table_effective -framelimits_body] - set eff_hlims [tcl::dict::get $o_opts_table_effective -framelimits_header] - - set requested_blims [tcl::dict::get $o_opts_table -framelimits_body] - set requested_hlims [tcl::dict::get $o_opts_table -framelimits_header] - set blims $eff_blims - set hlims $eff_hlims - switch -- $requested_blims { - "default" { - set blims $default_blims - } - default { - #set blims $requested_blims - set blims [list] - foreach lim $requested_blims { - switch -- $lim { - hl { - lappend blims hlt hlb - } - vl { - lappend blims vll vlr - } - default { - lappend blims $lim - } - } - } - set blims [lsort -unique $blims] - } - } - tcl::dict::set o_opts_table_effective -framelimits_body $blims - switch -- $requested_hlims { - "default" { - set hlims $default_hlims - } - default { - #set hlims $requested_hlims - set hlims [list] - foreach lim $requested_hlims { - switch -- $lim { - hl { - lappend hlims hlt hlb - } - vl { - lappend hlims vll vlr - } - default { - lappend hlims $lim - } - } - } - set hlims [lsort -unique $hlims] - } - } - tcl::dict::set o_opts_table_effective -framelimits_header $hlims - return [tcl::dict::create body $blims header $hlims] - } - method configure args { - if {![llength $args]} { - return $o_opts_table - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [list %topt_keys%]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_opts_table $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { - tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "[tcl::namespace::current]::table configure - unexpected argument count. Require name value pairs" - } - foreach {k v} $args { - switch -- $k { - %topt_switchkeys% {} - default { - error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - #if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { - # error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - #} - } - set checked_opts [list] - foreach {k v} $args { - switch -- $k { - -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set ansi_codes [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend ansi_codes $code - } - } - set ansival [punk::ansi::codetype::sgr_merge_singles $ansi_codes] - lappend checked_opts $k $ansival - } - -frametype - -frametype_header - -frametype_body { - #frametype will raise an error if v is not a valid custom dict or one of the known predefined types such as light,heavy,double etc - lassign [textblock::frametype $v] _cat category _type ftype - lappend checked_opts $k $v - } - -framemap_body - -framemap_header { - #upvar ::textblock::class::opts_table_defaults tdefaults - #set default_bmap [tcl::dict::get $tdefaults -framemap_body] - #todo - check keys and map - if {[llength $v] == 1} { - if {$v eq "default"} { - upvar ::textblock::class::opts_table_defaults tdefaults - set default_map [tcl::dict::get $tdefaults $k] - lappend checked_opts $k $default_map - } else { - error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}" - } - } else { - #safe jumptable test - #dict for {subk subv} $v {} - foreach {subk subv} $v { - switch -- $subk { - topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} - default { - error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" - } - } - #safe jumptable test - #dict for {seg subst} $subv {} - foreach {seg subst} $subv { - switch -- $seg { - hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {} - default { - error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}" - } - } - } - - } - lappend checked_opts $k $v - } - - } - -framelimits_body - -framelimits_header { - set specific_framelimits [list] - foreach fl $v { - switch -- $fl { - "default" { - lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr - } - hl { - lappend specific_framelimits hlt hlb - } - vl { - lappend specific_framelimits vll vlr - } - hlt - hlb - vll - vlr - trc - tlc - blc - brc { - lappend specific_framelimits $fl - } - default { - error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)" - } - } - } - lappend checked_opts $k $specific_framelimits - } - -ansireset { - if {$v eq "\uFFEF"} { - set RST "\x1b\[m" ;#[a] - lappend checked_opts $k $RST - } else { - error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -show_hseps { - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - lappend checked_opts $k $v - #these don't affect column width calculations - } - -show_edge { - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - lappend checked_opts $k $v - #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - } - -show_vseps { - #we allow empty string - so don't use -strict boolean check - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - #affects width calculations - set o_calculated_column_widths [list] - lappend checked_opts $k $v - } - -minwidth - -maxwidth { - set o_calculated_column_widths [list] - lappend checked_opts $k $v - } - default { - lappend checked_opts $k $v - } - } - } - #all options checked - ok to update o_opts_table and o_opts_table_effective - - #set o_opts_table [tcl::dict::merge $o_opts_table $checked_opts] - foreach {k v} $args { - switch -- $k { - -framemap_header - -framemap_body { - #framemaps don't require setting every key to update. - #e.g configure -framemaps {topleft } - #needs to merge with existing unspecified keys such as topright middleleft etc. - if {$v eq "default"} { - tcl::dict::set o_opts_table $k default - } else { - if {[tcl::dict::get $o_opts_table $k] eq "default"} { - tcl::dict::set o_opts_table $k $v - } else { - tcl::dict::set o_opts_table $k [tcl::dict::merge [tcl::dict::get $o_opts_table $k] $v] - } - } - } - default { - tcl::dict::set o_opts_table $k $v - } - } - } - #use values from checked_opts for the effective opts - #safe jumptable test - #dict for {k v} $checked_opts {} - #foreach {k v} $checked_opts {} - tcl::dict::for {k v} $checked_opts { - switch -- $k { - -framemap_body - -framemap_header { - set existing [tcl::dict::get $o_opts_table_effective $k] - #set updated $existing - #dict for {subk subv} $v { - # tcl::dict::set updated $subk $subv - #} - #tcl::dict::set o_opts_table_effective $k $updated - tcl::dict::set o_opts_table_effective $k [tcl::dict::merge $existing $v] - } - -framelimits_body - -framelimits_header { - #my Set_effective_framelimits - tcl::dict::set o_opts_table_effective $k $v - } - default { - tcl::dict::set o_opts_table_effective $k $v - } - } - } - #ansireset exception - tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] - return $o_opts_table - } - - #integrate with struct::matrix - allows ::m format 2string $table - method printmatrix {matrix} { - set matrix_rowcount [$matrix rows] - set matrix_colcount [$matrix columns] - set table_colcount [my column_count] - if {$table_colcount == 0} { - for {set c 0} {$c < $matrix_colcount} {incr c} { - my add_column -headers "" - } - } - set table_colcount [my column_count] - if {$table_colcount != $matrix_colcount} { - error "textblock::table::printmatrix column count of table doesn't match column count of matrix" - } - if {[my row_count] > 0} { - my row_clear - } - for {set r 0} {$r < $matrix_rowcount} {incr r} { - my add_row [$matrix get row $r] - } - my print - } - method as_matrix {{cmd ""}} { - if {$cmd eq ""} { - set m [struct::matrix] - } else { - set m [struct::matrix $cmd] - } - $m add columns [tcl::dict::size $o_columndata] - $m add rows [tcl::dict::size $o_rowdefs] - tcl::dict::for {k v} $o_columndata { - $m set column $k $v - } - return $m - } - method add_column {args} { - #*** !doctools - #[call class::table [method add_column] [arg args]] - - - if {[llength $args] %2 != 0} { - error "[tcl::namespace::current]::table::add_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" - } - set opts $o_opts_column_defaults - foreach {k v} $args { - switch -- $k { - %copt_switchkeys% { - tcl::dict::set opts $k $v - } - default { - error "[tcl::namespace::current]::table::add_column unknown option '$k'. Known options: %copt_keys%" - } - } - } - set colcount [tcl::dict::size $o_columndefs] - - - tcl::dict::set o_columndata $colcount [list] - #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists - tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists - - - tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] - set prev_calculated_column_widths $o_calculated_column_widths - if {[catch { - my configure_column $colcount {*}$opts - } errMsg]} { - #configure failed - ensure o_columndata and o_columndefs entries are removed - tcl::dict::unset o_columndata $colcount - tcl::dict::unset o_columndefs $colcount - tcl::dict::unset o_columnstates $colcount - #undo cache invalidation - set o_calculated_column_widths $prev_calculated_column_widths - error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" - } - #any add_column that succeeds should invalidate the calculated column widths - set o_calculated_column_widths [list] - set numrows [my row_count] - if {$numrows > 0} { - #fill column with default values - #puts ">>> adding default values for column $colcount" - set dval [tcl::dict::get $opts -defaultvalue] - set width [textblock::width $dval] - tcl::dict::set o_columndata $colcount [lrepeat $numrows $dval] - tcl::dict::set o_columnstates $colcount maxwidthbodyseen $width - tcl::dict::set o_columnstates $colcount minwidthbodyseen $width - } - return $colcount - } - method column_count {} { - return [tcl::dict::size $o_columndefs] - } - method configure_column {index_expression args} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" - } - if {![llength $args]} { - return [tcl::dict::get $o_columndefs $cidx] - } else { - if {[llength $args] == 1} { - if {[lindex $args 0] in [list %copt_keys%]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_columndefs $cidx $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - } else { - error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values %copt_keys%" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" - } - foreach {k v} $args { - switch -- $k { - %copt_switchkeys% {} - default { - error "[tcl::namespace::current]::table configure_column unknown option '$k'. Known options: %copt_keys%" - } - } - } - set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state - - set hstates $o_headerstates ;#operate on a copy - set colstate [tcl::dict::get $o_columnstates $cidx] - set args_got_headers 0 - set args_got_header_colspans 0 - foreach {k v} $args { - switch -- $k { - -headers { - set args_got_headers 1 - set i 0 - set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. - foreach hdr $v { - set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns - #set this_header_height [textblock::height $hdr] - lassign [textblock::size $hdr] _w this_header_width _h this_header_height - - if {$this_header_height >= $currentmax} { - tcl::dict::set hstates $i maxheightseen $this_header_height - } else { - tcl::dict::set hstates $i maxheightseen $currentmax - } - if {$this_header_width >= $maxseen} { - set maxseen $this_header_width - } - #if {$this_header_width > [tcl::dict::get $colstate maxwidthheaderseen]} { - # tcl::dict::set colstate maxwidthheaderseen $this_header_width - #} - incr i - } - tcl::dict::set colstate maxwidthheaderseen $maxseen - #review - we could avoid some recalcs if we check current width range compared to previous - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -header_colspans { - set args_got_header_colspans 1 - #check columns to left to make sure each new colspan for this column makes sense in the overall context - #user may have to adjust colspans in order left to right to avoid these check errors - #note that 'any' represents span all up to the next non-zero defined colspan. - set cspans [my header_colspans] - set h 0 - if {[llength $v] > [tcl::dict::size $cspans]} { - error "configure_column $cidx -header_colspans. Only [tcl::dict::size $cspans] headers exist. Too many values supplied" - } - foreach s $v { - if {$cidx == 0} { - if {[tcl::string::is integer -strict $s]} { - if {$s < 1} { - error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'any' or a positive integer" - } - } else { - if {$s ne "any" && $s ne ""} { - error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" - } - } - } else { - #if {![tcl::string::is integer -strict $s]} { - # if {$s ne "any" && $s ne ""} { - # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" - # } - #} else { - set header_spans [tcl::dict::get $cspans $h] - set remaining [lindex $header_spans 0] - if {$remaining ne "any"} { - incr remaining -1 - } - #look at spans defined for previous cols - #we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption - for {set c 0} {$c < $cidx} {incr c} { - set span [lindex $header_spans $c] - if {$span eq "any"} { - set remaining "any" - } else { - if {$remaining eq "any"} { - if {$span ne "0"} { - #a previous column has ended the 'any' span - set remaining [expr {$span -1}] - } - } else { - if {$span eq "0"} { - incr remaining -1 - } else { - set remaining [expr {$span -1}] - } - #allow to go negative - } - } - } - if {$remaining eq "any"} { - #any int >0 ok - what about 'any' immediately following any? - } else { - if {$remaining > 0} { - if {$s ne "0" && $s ne ""} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. Remaining span is '$remaining' - so a zero colspan is required" - } - } else { - if {$s == 0} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" - } - } - } - #} - } - incr h - } - #todo - avoid recalc if no change - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -minwidth { - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -maxwidth { - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set col_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend col_ansibase_items $code - } - } - set col_ansibase [punk::ansi::codetype::sgr_merge_singles $col_ansibase_items] - tcl::dict::set checked_opts $k $col_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - tcl::dict::set checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -blockalign - -textalign { - switch -- $v { - left - right { - tcl::dict::set checked_opts $k $v - } - centre - centre { - tcl::dict::set checked_opts $k centre - } - } - } - default { - tcl::dict::set checked_opts $k $v - } - } - } - #args checked - ok to update headerstates and columndefs and columnstates - tcl::dict::set o_columndefs $cidx $checked_opts - - set o_headerstates $hstates - tcl::dict::set o_columnstates $cidx $colstate - - if {$args_got_headers} { - #if the headerlist length for this column has shrunk,and it was the longest - we may now have excess entries in o_headerstates - set zero_heights [list] - tcl::dict::for {hidx _v} $o_headerstates { - #pass empty string for exclude_column so we don't exclude our own column - if {[my header_height_calc $hidx ""] == 0} { - lappend zero_heights $hidx - } - } - foreach zidx $zero_heights { - tcl::dict::unset o_headerstates $zidx - } - } - if {$args_got_headers || $args_got_header_colspans} { - #check and adjust header_colspans for all columns - - } - - return [tcl::dict::get $o_columndefs $cidx] - } - } - - method header_count {} { - return [tcl::dict::size $o_headerstates] - } - method header_count_calc {} { - set max_headers 0 - tcl::dict::for {k cdef} $o_columndefs { - set num_headers [llength [tcl::dict::get $cdef -headers]] - set max_headers [expr {max($max_headers,$num_headers)}] - } - return $max_headers - } - method header_height {header_index} { - set idx [lindex [tcl::dict::keys $o_headerstates $header_index]] - return [tcl::dict::get $o_headerstates $idx maxheightseen] - } - - #review - use maxwidth (considering colspans) of each column to determine height after wrapping - # -need to consider whether vertical expansion allowed / maxheight? - method header_height_calc {header_index {exclude_column ""}} { - set dataheight 0 - if {$exclude_column eq ""} { - set exclude_colidx "" - } else { - set exclude_colidx [lindex [tcl::dict::keys $o_columndefs] $exclude_column] - } - tcl::dict::for {cidx cdef} $o_columndefs { - if {$exclude_colidx == $cidx} { - continue - } - set headerlist [tcl::dict::get $cdef -headers] - if {$header_index < [llength $headerlist]} { - set this_height [textblock::height [lindex $headerlist $header_index]] - set dataheight [expr {max($dataheight,$this_height)}] - } - } - return $dataheight - } - - #return a dict keyed on header index with values representing colspans - #e.g - # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} - # - method header_colspans {} { - #set num_headers [my header_count_calc] - set num_headers [my header_count] - set colspans_by_header [tcl::dict::create] - tcl::dict::for {cidx cdef} $o_columndefs { - set headerlist [tcl::dict::get $cdef -headers] - set colspans_for_column [tcl::dict::get $cdef -header_colspans] - for {set h 0} {$h < $num_headers} {incr h} { - set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] - set defined_span [lindex $colspans_for_column $h] - set i 0 - set spanremaining [lindex $headerspans 0] - if {$spanremaining ne "any"} { - if {$spanremaining eq ""} { - set spanremaining 1 - } - incr spanremaining -1 - } - foreach s $headerspans { - if {$s eq "any"} { - set spanremaining "any" - } elseif {$s == 0} { - if {$spanremaining ne "any"} { - incr spanremaining -1 - } - } else { - set spanremaining [expr {$s - 1}] - } - incr i - } - if {$defined_span eq ""} { - if {$spanremaining eq "0"} { - lappend headerspans 1 - } else { - #"any" or an integer - lappend headerspans 0 - } - } else { - lappend headerspans $defined_span - } - tcl::dict::set colspans_by_header $h $headerspans - } - } - return $colspans_by_header - } - - #e.g - # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 any 1} 3 {any 0 0 1} - #convert to - # 0 {4 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} - method header_colspans_numeric {} { - set hcolspans [my header_colspans] - if {![tcl::dict::size $hcolspans]} { - return - } - set numcols [llength [tcl::dict::get $hcolspans 0]] ;#assert: all are the same - tcl::dict::for {h spans} $hcolspans { - set c 0 ;#column index - foreach s $spans { - if {$s eq "any"} { - set spanlen 1 - for {set i [expr {$c+1}]} {$i < $numcols} {incr i} { - #next 'any' or non-zero ends an 'any' span - if {[lindex $spans $i] ne "0"} { - break - } - incr spanlen - } - #overwrite the 'any' with it's actual span - set modified_spans [dict get $hcolspans $h] - lset modified_spans $c $spanlen - dict set hcolspans $h $modified_spans - } - incr c - } - } - return $hcolspans - } - - #should be configure_headerrow ? - method configure_header {index_expression args} { - #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. - #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis - #e.g o_headerstates: 0 {maxheightseen 1} 1 {maxheightseen 2} - set num_headers [my header_count_calc] - set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression] - if {$hidx eq ""} { - error "textblock::table::configure_header - no row defined at index '$hidx'." - } - if {$hidx > $num_headers -1} { - #assert - shouldn't happen - error "textblock::table::configure_header error headerstates data is out of sync" - } - - if {![llength $args]} { - set colspans_by_header [my header_colspans] - set result [tcl::dict::create] - tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] - set header_row_items [list] - tcl::dict::for {cidx cdef} $o_columndefs { - set colheaders [tcl::dict::get $cdef -headers] - set relevant_header [lindex $colheaders $hidx] - #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. - } - tcl::dict::set result -values $header_row_items - return $result - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [tcl::dict::keys $o_opts_header_defaults]} { - #query single option - set k [lindex $args 0] - #set val [tcl::dict::get $o_rowdefs $ridx $k] - - set infodict [tcl::dict::create] - #todo - # -blockalignments and -textalignments lists - # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} - #if there is a value it overrides alignments specified on the column - switch -- $k { - -values { - set header_row_items [list] - tcl::dict::for {cidx cdef} $o_columndefs { - set colheaders [tcl::dict::get $cdef -headers] - set relevant_header [lindex $colheaders $hidx] - #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. - - } - set val $header_row_items - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - } - -colspans { - set colspans_by_header [my header_colspans] - set result [tcl::dict::create] - set val [tcl::dict::get $colspans_by_header $hidx] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - } - -ansibase { - set val ??? - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_header_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_header_defaults]" - } - foreach {k v} $args { - if {$k ni [tcl::dict::keys $o_opts_header_defaults]} { - error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_header_defaults]" - } - } - - set checked_opts [list] - #safe jumptable test - #dict for {k v} $args {} - foreach {k v} $args { - switch -- $k { - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set header_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend header_ansibase_items $code - } - } - set header_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] - error "sorry - -ansibase not yet implemented for header rows" - lappend checked_opts $k $header_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - lappend checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -values { - if {[llength $v] > [tcl::dict::size $o_columndefs]} { - error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" - } - lappend checked_opts $k $v - } - -colspans { - set numcols [tcl::dict::size $o_columndefs] - if {[llength $v] > $numcols} { - error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" - } - if {[llength $v] < $numcols} { - puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." - puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" - } - if {[llength $v]} { - set firstspan [lindex $v 0] - set first_is_ok 0 - if {$firstspan eq "any"} { - set first_is_ok 1 - } elseif {[tcl::string::is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} { - set first_is_ok 1 - } - if {!$first_is_ok} { - error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" - } - #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) - set remaining $firstspan - if {$remaining ne "any"} { - incr remaining -1 - } - set spanview $v - set sidx 1 - #because we allow 'any' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'any' first - foreach span [lrange $v 1 end] { - if {$remaining eq "any"} { - if {$span eq "any"} { - set remaining "any" - } elseif {$span > 0} { - #ok to reset to higher val immediately or after an any and any number of following zeros - if {$span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" - } - set remaining $span - incr remaining -1 - } else { - #zero following an any - leave remaining as any - } - } else { - if {$span eq "0"} { - if {$remaining eq "0"} { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" - } else { - incr remaining -1 - } - } else { - if {$remaining eq "0"} { - #ok for new span value of any or > 0 - if {$span ne "any" && $span > ($numcols - $sidx)} { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" - } - set remaining $span - if {$remaining ne "any"} { - incr remaining -1 - } - } else { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" - } - } - } - incr sidx - } - } - #empty -colspans list should be ok - - #error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now" - lappend checked_opts $k $v - } - default { - lappend checked_opts $k $v - } - } - } - - #configured opts all good - #safe jumptable test - #dict for {k v} $checked_opts {} - #foreach {k v} $checked_opts {} - tcl::dict::for {k v} $checked_opts { - switch -- $k { - -values { - set c 0 - foreach hval $v { - #retrieve -headers from relevant col, insert at header index, and write back. - set thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers] - set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}] - if {$missing > 0} { - lappend thiscol_headers_vertical {*}[lrepeat $missing ""] - } - lset thiscol_headers_vertical $hidx $hval - tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical - #invalidate column width cache - set o_calculated_column_widths [list] - # -- -- -- -- -- -- - #also update maxwidthseen & maxheightseen - set i 0 - set maxwidthseen 0 - #set maxheightseen 0 - foreach hdr $thiscol_headers_vertical { - lassign [textblock::size $hdr] _w this_header_width _h this_header_height - set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0] - if {$this_header_height >= $maxheightseen} { - tcl::dict::set o_headerstates $i maxheightseen $this_header_height - } else { - tcl::dict::set o_headerstates $i maxheightseen $maxheightseen - } - if {$this_header_width >= $maxwidthseen} { - set maxwidthseen $this_header_width - } - incr i - } - tcl::dict::set o_columnstates $c maxwidthheaderseen $maxwidthseen - # -- -- -- -- -- -- - incr c - } - } - -colspans { - #sequence has been verified above - we need to split it and store across columns - set c 0 ;#column index - foreach span $v { - set colspans [tcl::dict::get $o_columndefs $c -header_colspans] - if {$hidx > [llength $colspans]-1} { - set colspans_by_header [my header_colspans] - #puts ">>>>>?$colspans_by_header" - #we are allowed to lset only one beyond the current length to append - #but there may be even less or no entries present in a column - # - the ability to underspecify and calculate the missing values makes setting the values complicated. - #use the header_colspans calculation to update only those entries necessary - set spanlist [list] - for {set h 0} {$h < $hidx} {incr h} { - set cspans [tcl::dict::get $colspans_by_header $h] - set requiredval [lindex $cspans $c] - lappend spanlist $requiredval - } - tcl::dict::set o_columndefs $c -header_colspans $spanlist - - set colspans [tcl::dict::get $o_columndefs $c -header_colspans] - } - - lset colspans $hidx $span - tcl::dict::set o_columndefs $c -header_colspans $colspans - incr c - } - } - } - } - } - - method add_row {valuelist args} { - #*** !doctools - #[call class::table [method add_row] [arg args]] - if {[tcl::dict::size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [tcl::dict::size $o_columndefs])} { - set msg "" - append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [tcl::dict::size $o_columndefs]" \n - append msg "rowdata: $valuelist" - error $msg - } - if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { - error "add_row - no values supplied, and no columns defined, so cannot use default column values" - } - - set defaults [tcl::dict::create\ - -minheight 1\ - -maxheight ""\ - -ansibase ""\ - -ansireset "\uFFEF"\ - ] - set o_opts_row_defaults $defaults - - if {[llength $args] %2 !=0} { - error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" - } - #safe jumptable test - #dict for {k v} $args {} - foreach {k v} $args { - switch -- $k { - -minheight - -maxheight - -ansibase - -ansireset {} - default { - error "Invalid option '$k' Known options: [tcl::dict::keys $defaults] (-ansireset is read-only)" - } - } - } - set opts [tcl::dict::merge $defaults $args] - - set auto_columns 0 - if {[tcl::dict::size $o_columndefs] == 0} { - set auto_columns 1 - #no columns defined - auto define with defaults for each column in first supplied row - #auto define columns only valid if no existing columns - #the autocolumns must be added before configure_row - but if configure_row fails - we need to remove them! - foreach el $valuelist { - my add_column - } - } else { - if {![llength $valuelist]} { - tcl::dict::for {k coldef} $o_columndefs { - lappend valuelist [tcl::dict::get $coldef -defaultvalue] - } - } - } - set rowcount [tcl::dict::size $o_rowdefs] - tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure - - if {[catch { - my configure_row $rowcount {*}$opts - } errMsg]} { - #undo anything we saved before configure_row - tcl::dict::unset o_rowdefs $rowcount - #remove auto_columns - if {$auto_columns} { - set o_columndata [tcl::dict::create] - set o_columndefs [tcl::dict::create] - set o_columnstate [tcl::dict::create] - } - error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" - } - - - set c 0 - set max_height_seen 1 - foreach v $valuelist { - set prev_maxwidth [tcl::dict::get $o_columnstates $c maxwidthbodyseen] - set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] - - tcl::dict::lappend o_columndata $c $v - set valheight [textblock::height $v] - if {$valheight > $max_height_seen} { - set max_height_seen $valheight - } - set width [textblock::width $v] - if {$width > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { - tcl::dict::set o_columnstates $c maxwidthbodyseen $width - } - if {$width < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { - tcl::dict::set o_columnstates $c minwidthbodyseen $width - } - - if {[tcl::dict::get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [tcl::dict::get $o_columnstates $c minwidthbodyseen] < $prev_minwidth} { - #invalidate calculated column width cache if any new value was outside the previous range of widths - set o_calculated_column_widths [list] - } - incr c - } - - set opt_maxh [tcl::dict::get $o_rowdefs $rowcount -maxheight] - if {$opt_maxh ne ""} { - tcl::dict::set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}] - } else { - tcl::dict::set o_rowstates $rowcount -maxheight $max_height_seen - } - - return $rowcount - } - method configure_row {index_expression args} { - set ridx [lindex [tcl::dict::keys $o_rowdefs] $index_expression] - if {$ridx eq ""} { - error "textblock::table::configure_row - no row defined at index '$ridx'.Use add_row to define rows" - } - if {![llength $args]} { - return [tcl::dict::get $o_rowdefs $ridx] - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [tcl::dict::keys $o_opts_row_defaults]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_rowdefs $ridx $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_row_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_row_defaults]" - } - foreach {k v} $args { - if {$k ni [tcl::dict::keys $o_opts_row_defaults]} { - error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_row_defaults]" - } - } - set checked_opts [list] - foreach {k v} $args { - switch -- $k { - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set row_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend row_ansibase_items $code - } - } - set row_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] - lappend checked_opts $k $row_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - lappend checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_row -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - default { - lappend checked_opts $k $v - } - } - } - - set current_opts [tcl::dict::get $o_rowdefs $ridx] - set opts [tcl::dict::merge $current_opts $checked_opts] - - #check minheight and maxheight together - set opt_minh [tcl::dict::get $opts -minheight] - set opt_maxh [tcl::dict::get $opts -maxheight] - - #todo - allow zero values to hide/collapse rows as is possible with columns - if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { - error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" - } - if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { - error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" - } - if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { - error "[tcl::namespace::current]::table::configure_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" - } - tcl::dict::set o_rowstates $ridx -minheight $opt_minh - - - tcl::dict::set o_rowdefs $ridx $opts - } - method row_count {} { - return [tcl::dict::size $o_rowdefs] - } - method row_clear {} { - set o_rowdefs [tcl::dict::create] - set o_rowstates [tcl::dict::create] - #The data values are stored by column regardless of whether added row by row - tcl::dict::for {cidx records} $o_columndata { - tcl::dict::set o_columndata $cidx [list] - #reset only the body fields in o_columnstates - tcl::dict::set o_columnstates $cidx minwidthbodyseen 0 - tcl::dict::set o_columnstates $cidx maxwidthbodyseen 0 - } - set o_calculated_column_widths [list] - } - method clear {} { - my row_clear - set o_columndefs [tcl::dict::create] - set o_columndata [tcl::dict::create] - set o_columnstates [tcl::dict::create] - } - - - - #method Get_columns_by_name {namematch_list} { - #} - - #specify range with x..y - method Get_columns_by_indices {index_list} { - foreach spec $index_list { - if {[tcl::string::is integer -strict $c]} { - set colidx $c - } else { - tcl::dict::for {colidx coldef} $o_columndefs { - #if {[tcl::string::match x x]} {} - } - } - } - } - method Get_boxlimits_and_joins {position fname_body} { - #fname_body will be "custom" or one of the predefined types light,heavy etc - switch -- $position { - left { - return [tcl::dict::create \ - boxlimits [list hlb blc vll]\ - boxlimits_top [list hlb blc vll hlt tlc]\ - joins [list down]\ - bodyjoins [list down-$fname_body]\ - ] - } - inner { - return [tcl::dict::create \ - boxlimits [list hlb blc vll]\ - boxlimits_top [list hlb blc vll hlt tlc]\ - joins [list down left]\ - bodyjoins [list left down-$fname_body] - ] - } - right { - return [tcl::dict::create \ - boxlimits [list hlb blc vll vlr brc]\ - boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ - joins [list down left]\ - bodyjoins [list left down-$fname_body]\ - ] - } - solo { - return [tcl::dict::create \ - boxlimits [list hlb blc vll vlr brc]\ - boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ - joins [list down]\ - bodyjoins [list down-$fname_body]\ - ] - } - default { - error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo" - } - } - } - method Get_boxlimits_and_joins1 {position fname_body} { - #fname_body will be "custom" or one of the predefined types light,heavy etc - switch -- $position { - left { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list down-$fname_body] - set boxlimits_position [list hlb blc vll] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set boxlimits_toprow [list hlb blc vll hlt tlc] - set joins [list down] - } - inner { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list left down-$fname_body] - set boxlimits_position [list hlb blc vll] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set boxlimits_toprow [list hlb blc vll hlt tlc] - set joins [list down left] - } - right { - #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} - set header_body_joins [list left down-$fname_body] - set boxlimits_position [list hlb blc vll vlr brc] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] - set joins [list down left] - } - solo { - #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} - set header_body_joins [list down-$fname_body] - set boxlimits_position [list hlb blc vll vlr brc] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] - set joins [list down] - } - } - return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ] - } - method get_column_by_index {index_expression args} { - #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" - #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. - set opts [tcl::dict::create\ - -position "inner"\ - -return "string"\ - ] - foreach {k v} $args { - switch -- $k { - -position - -return { - tcl::dict::set opts $k $v - } - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid option '$k'. Known options [tcl::dict::keys $opts]" - } - } - } - set opt_posn [tcl::dict::get $opts -position] - set opt_return [tcl::dict::get $opts -return] - - switch -- $opt_posn { - left - inner - right - solo {} - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo]" - } - } - switch -- $opt_return { - string - dict {} - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_return' for -return. Valid values: string dict" - } - } - - set columninfo [my get_column_cells_by_index $index_expression] - set header_list [tcl::dict::get $columninfo headers] - #puts "===== header_list: $header_list" - set cells [tcl::dict::get $columninfo cells] - - set topt_show_header [tcl::dict::get $o_opts_table -show_header] - if {$topt_show_header eq ""} { - set allheaders 0 - set all_cols [tcl::dict::keys $o_columndefs] - foreach c $all_cols { - incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] - } - if {$allheaders == 0} { - set do_show_header 0 - } else { - set do_show_header 1 - } - } else { - set do_show_header $topt_show_header - } - set topt_show_footer [tcl::dict::get $o_opts_table -show_footer] - - - set output "" - set part_header "" - set part_body "" - set part_footer "" - - set boxlimits "" - set joins "" - set header_boxlimits [list] - set header_body_joins [list] - - - set ftypes [my Get_frametypes] - set ftype_body [tcl::dict::get $ftypes body] - if {[llength $ftype_body] >= 2} { - set fname_body "custom" - } else { - set fname_body $ftype_body - } - set ftype_header [tcl::dict::get $ftypes header] - if {[llength $ftype_header] >= 2} { - set fname_header "custom" - } else { - set fname_header $ftype_header - } - - set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] - set header_body_joins [tcl::dict::get $limj bodyjoins] - set joins [tcl::dict::get $limj joins] - set boxlimits_position [tcl::dict::get $limj boxlimits] - set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] - #use struct::set instead of simple for loop - will be faster at least when critcl available - set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] - set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] - set header_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_position] - set header_boxlimits_toprow [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_toprow] - - set fmap [tcl::dict::get $o_opts_table_effective -framemap_body] - set hmap [tcl::dict::get $o_opts_table_effective -framemap_header] - - #if {![tcl::dict::get $o_opts_table -show_edge]} { - # set body_edgemap [textblock::class::table_edge_map ""] - # dict for {k v} $fmap { - # #tcl::dict::set fmap $k [tcl::dict::merge $v [tcl::dict::get $body_edgemap $k]] - # } - # set header_edgemap [textblock::class::header_edge_map ""] - # dict for {k v} $hmap { - # #tcl::dict::set hmap $k [tcl::dict::merge $v [tcl::dict::get $header_edgemap $k]] - # } - #} - set sep_elements_horizontal $::textblock::class::table_hseps - set sep_elements_vertical $::textblock::class::table_vseps - - set topmap [tcl::dict::get $fmap top$opt_posn] - set botmap [tcl::dict::get $fmap bottom$opt_posn] - set midmap [tcl::dict::get $fmap middle$opt_posn] - set onlymap [tcl::dict::get $fmap only$opt_posn] - - set hdrmap [tcl::dict::get $hmap only${opt_posn}] - - set topseps_h [tcl::dict::get $sep_elements_horizontal top$opt_posn] - set midseps_h [tcl::dict::get $sep_elements_horizontal middle$opt_posn] - set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] - set midseps_v [tcl::dict::get $sep_elements_vertical middle$opt_posn] - set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] - set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] - - #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway - set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] - - lassign [my Get_seps] _h show_seps_h _v show_seps_v - set return_headerheight 0 - set return_headerwidth 0 - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - - set colwidth [my column_width $cidx] - - set col_blockalign [tcl::dict::get $o_columndefs $cidx -blockalign] - - if {$do_show_header} { - #puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap" - set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure - set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] - if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { - set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] - set ansiborder_final $ansibase_header$ansiborder_header$extrabg - } else { - set ansiborder_final $ansibase_header$ansiborder_header - } - set RST [punk::ansi::a] - - - set hcolwidth $colwidth - #set hcolwidth [my column_width_configured $cidx] - set hcell_line_blank [tcl::string::repeat " " $hcolwidth] - - set all_colspans [my header_colspans_numeric] - - #put our framedef calls together - set fdef_header [textblock::framedef $ftype_header] - set framedef_leftbox [textblock::framedef -joins left $ftype_header] - set framedef_headerdown_same [textblock::framedef -joins {down} $ftype_header] - set framedef_headerdown_body [textblock::framedef -joins [list down-$fname_body] $ftype_header] - #default span_extend_map - used as base to customise with specific joins - set span_extend_map [tcl::dict::create \ - vll " "\ - tlc [tcl::dict::get $fdef_header hlt]\ - blc [tcl::dict::get $fdef_header hlb]\ - ] - - - #used for colspan-zero header frames - set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test - - set hrow 0 - set hmax [expr {[llength $header_list] -1}] - foreach header $header_list { - set headerspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerspans $cidx] - set hval $ansibase_header$header ;#no reset - set rowh [my header_height $hrow] - - #set h_lines [lrepeat $rowh $hcell_line_blank] - #set hcell_blank [join $h_lines \n] - #set hval_lines [split $hval \n] - #set hval_lines [lrange $hval_lines 0 $rowh-1] - #set hval_block [join $hval_lines \n] - #set headercell [overtype::left -experimental test_mode $ansibase_header$hcell_blank$RST $hval_block] - - if {$hrow == 0} { - set hlims $header_boxlimits_toprow - set rowpos "top" - if {$hrow == $hmax} { - set rowpos "only" - } - } else { - set hlims $header_boxlimits - set rowpos "middle" - if {$hrow == $hmax} { - set rowpos "bottom" - } - } - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {$hrow == $hmax} { - set header_joins $header_body_joins - } else { - set header_joins $joins - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] - } - #puts ">>> headerspans: $headerspans cidx: $cidx" - - #if {$this_span eq "any" || $this_span > 0} {} - #changed to processing only numeric colspans - - if {$this_span > 0} { - set startmap [tcl::dict::get $hmap $rowpos${opt_posn}] - #look at spans in header below to determine joins required at blc - if {$show_seps_v} { - if {[tcl::dict::exists $all_colspans [expr {$hrow+1}]]} { - set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] - set spanbelow [lindex $next_spanlist $cidx] - if {$spanbelow == 0} { - #we don't want a down-join for blc - use a framedef with only left joins - tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] - } - } else { - set next_spanlist [list] - } - } - - #supporting wrapping in headers might be a step too difficult for little payoff. - #we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib) - #The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex. - #May be better to require user to pre-wrap as needed - ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] - - #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used - #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) - - # -width is always +2 - as the boxlimits take into account show_vseps and show_edge - #set header_cell_startspan [textblock::frame -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - # -ansibase $ansibase_header -ansiborder $ansiborder_final\ - # -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\ - # ] - - if {$this_span == 1} { - #write the actual value now - set cellcontents $hval - } else { - #just write an empty vertical placeholder. The spanned value will be overtyped below - set cellcontents [::join [lrepeat [llength [split $hval \n]] ""] \n] - } - set header_cell_startspan [textblock::frame -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ - ] - - if {$this_span != 1} { - #puts "===>\n$header_cell_startspan\n<===" - set spanned_parts [list $header_cell_startspan] - #assert this_span == "any" or >1 ie a header that spans other columns - #therefore more parts to append - #set remaining_cols [lrange [tcl::dict::keys $o_columndefs] $cidx end] - set remaining_spans [lrange $headerspans $cidx+1 end] - set spanval [join $remaining_spans ""] ;#so we can test for all zeros - set spans_to_rhs 0 - if {[expr {$spanval}] == 0} { - #puts stderr "SPANS TO RHS" - set spans_to_rhs 1 - } - - #puts ">> remaining_spans: $remaining_spans" - set spancol [expr {$cidx + 1}] - set h_lines [lrepeat $rowh ""] - set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow - - - - set last [expr {[llength $remaining_spans] -1}] - set i 0 - foreach s $remaining_spans { - if {$s == 0} { - if {$i == $last} { - set next_posn right - #set next_posn inner - } else { - set next_posn inner - } - - set next_headerseps_v [tcl::dict::get $sep_elements_vertical top$next_posn] ;#static top ok - - set limj [my Get_boxlimits_and_joins $next_posn $fname_body] - set span_joins_body [tcl::dict::get $limj bodyjoins] - set span_joins [tcl::dict::get $limj joins] - set span_boxlimits [tcl::dict::get $limj boxlimits] - set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] - #use struct::set instead of simple for loop - will be faster at least when critcl available - #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] - #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] - set header_span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits] - set header_span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits_top] - if {$hrow == 0} { - set hlims $header_span_boxlimits_top - } else { - set hlims $header_span_boxlimits - } - - set this_span_map $span_extend_map - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $next_headerseps_v] - } else { - if {[llength $next_spanlist]} { - set spanbelow [lindex $next_spanlist $spancol] - if {$spanbelow != 0} { - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype - } - } else { - #join to body - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype - } - } - - if {$hrow == $hmax} { - set header_joins $span_joins_body - } else { - set header_joins $span_joins - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] - } - - set contentwidth [my column_width $spancol] - set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\ - ] - lappend spanned_parts $header_cell - } else { - break - } - incr spancol - incr i - } - - #JMN - #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic - set spanned_frame [textblock::join_basic -- {*}$spanned_parts] - - if {$spans_to_rhs} { - if {$cidx == 0} { - set fake_posn solo - } else { - set fake_posn right - } - set x_limj [my Get_boxlimits_and_joins $fake_posn $fname_body] - if {$hrow == 0} { - set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] - set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] - } else { - set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] - set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] - } - } else { - if {$hrow == 0} { - set hlims $header_boxlimits_toprow - } else { - set hlims $header_boxlimits - } - } - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - if {$spans_to_rhs} { - #assert fake_posn has been set above based on cidx and spans_to_rhs - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts ${rowpos}$fake_posn] ] - } else { - #use the edge_parts corresponding to the column being written to ie use opt_posn - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] - } - } - - set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements - #set spacemap [list hl * vl * tlc * blc * trc * brc *] - #-usecache 1 ok - #hval is not raw headerval - it has been padded to required width and has ansi applied - set hblock [textblock::frame -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase - #puts "==>boxlimits:'$hlims' hval_width:[tcl::string::length $hval] blockwidth:[textblock::width $hblock]" - #puts $hblock - #puts "==>hval:'$hval'[a]" - #puts "==>hval:'[ansistring VIEW $hval]'" - #set spanned_frame [overtype::renderspace -experimental test_mode -transparent 1 $spanned_frame $hblock] - - #spanned values default left - todo make configurable - - #TODO - #consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span - #we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes? - #this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span. - #(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned) - - set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] - #POTENTIAL BUG (fixed with spans_to_rhs above) - #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) - #we need to shift 1 to the left when doing our overtype with blockalign right - #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge - #(even though the column position may be left or inner) - - - - } else { - #this_span == 1 - set spanned_frame [textblock::join_basic -- $header_cell_startspan] - } - - - append part_header $spanned_frame - append part_header \n - } else { - #zero span header directly in this column ie one that is being colspanned by some column to our left - #previous col will already have built lines for this in it's own header rhs overhang - #we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent. - - #set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1] - - #if there are no header elements above then we will need a minimum of the column width - #may be extended to the widest portion of the header in the loop below - set padwidth [my column_width $cidx] - - - #under assumption we are building table using L frame method and that horizontal borders are only ever 1 high - # - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc - #avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 ) - if 0 { - #breaks -show_edge 0 - if {$rowpos eq "top" && [tcl::dict::get $o_opts_table -show_edge]} { - set padheight [expr {$rowh + 2}] - } else { - set padheight [expr {$rowh + 1}] - } - set bline [tcl::string::repeat $TSUB [expr {$padwidth +1}]] - set h_lines [lrepeat $padheight $bline] - set hcell_blank [::join $h_lines \n] - set header_frame $hcell_blank - } else { - set bline [tcl::string::repeat $TSUB $padwidth] - set h_lines [lrepeat $rowh $bline] - set hcell_blank [::join $h_lines \n] - # -usecache 1 ok - #frame borders will never display - so use the simplest frametype and don't apply any ansi - #puts "===>zerospan hlims: $hlims" - set header_frame [textblock::frame -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ - -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ - ] - } - - append part_header $header_frame\n - - } - incr hrow - } - if {![llength $header_list]} { - #no headers - but we've been asked to show_header - #display a zero content-height header (ie outline if edge is being shown - or bottom bar) - set hlims $header_boxlimits_toprow - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts only$opt_posn] ] - } - set header_joins $header_body_joins - set header_frame [textblock::frame -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $hdrmap -joins $header_joins\ - ] - append part_header $header_frame\n - } - set part_header [tcl::string::trimright $part_header \n] - lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight - - set padline [tcl::string::repeat $TSUB $return_headerwidth] - set adjusted_lines [list] - foreach ln [split $part_header \n] { - if {[tcl::string::first $TSUB $ln] >=0} { - lappend adjusted_lines $padline - } else { - lappend adjusted_lines $ln - } - } - set part_header [::join $adjusted_lines \n] - #append output $part_header \n - } - - set r 0 - set rmax [expr {[llength $cells]-1}] - - - set blims_mid $boxlimits - set blims_top $boxlimits - set blims_bot $boxlimits - set blims_top_headerless $boxlimits_headerless - set blims_only $boxlimits - set blims_only_headerless $boxlimits_headerless - if {!$show_seps_h} { - set blims_mid [struct::set difference $blims_mid $midseps_h] - set blims_top [struct::set difference $blims_top $topseps_h] - set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_h] - } - if {!$show_seps_v} { - set blims_mid [struct::set difference $blims_mid $midseps_v] - set blims_top [struct::set difference $blims_top $topseps_v] - set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_v] - set blims_bot [struct::set difference $blims_bot $botseps_v] - set blims_only [struct::set difference $blims_only $onlyseps_v] - set blims_only_headerless [struct::set difference $blims_only_headerless $onlyseps_v] - } - - set colidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range - - set opt_col_ansibase [tcl::dict::get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column - #set colwidth [my column_width $colidx] - - set body_ansibase [tcl::dict::get $o_opts_table -ansibase_body] - #set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body - set body_ansiborder [tcl::dict::get $o_opts_table -ansiborder_body] - if {[tcl::dict::get $o_opts_table -frametype] eq "block"} { - #block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled - #we need to only accept background ansi codes from the columndef ansibase for this - set col_bg [punk::ansi::codetype::sgr_merge_singles [list $opt_col_ansibase] -filter_fg 1] ;#special merge for block borders - don't override fg colours - set border_ansi $body_ansibase$body_ansiborder$col_bg - } else { - set border_ansi $body_ansibase$body_ansiborder - } - - - set r 0 - set ftblock [expr {[tcl::dict::get $o_opts_table -frametype] eq "block"}] - foreach c $cells { - #cells in column - each new c is in a different row - set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - set row_bg "" - if {$row_ansibase ne ""} { - set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] - } - - set ansibase $body_ansibase$opt_col_ansibase - #todo - joinleft,joinright,joindown based on opts in args - set cell_ansibase "" - - set ansiborder_body_col_row $border_ansi$row_bg - set ansiborder_final $ansiborder_body_col_row - #$c will always have ansi resets due to overtype behaviour ? - #todo - review overtype - if {[punk::ansi::ta::detect $c]} { - #use only the last ansi sequence in the cell value - #Filter out foreground and use background for ansiborder override - set parts [punk::ansi::ta::split_codes_single $c] - #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt - set codes [list] - foreach {pt cd} $parts { - if {$cd ne ""} { - lappend codes $cd - } - } - #set takebg [lindex $parts end-1] - #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] - set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] - #puts --->[ansistring VIEW $codes] - - if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { - if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { - #special case double reset at end of content - set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters - set ansibase "" - set row_ansibase "" - if {$ftblock} { - set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1] - } - set cell_ansibase $cell_ansi_tail - } else { - #single trailing reset in content - set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase - } - } else { - if {$ftblock} { - #no resets - use cell's bg to extend to the border - only for block frames - set ansiborder_final $ansiborder_body_col_row$cell_bg - } - set cell_ansibase $cell_bg - } - } - - set ansibase_final $ansibase$row_ansibase$cell_ansibase - - if {$r == 0} { - if {$r == $rmax} { - set joins [lremove $joins [lsearch $joins down*]] - set bmap $onlymap - if {$do_show_header} { - set blims $blims_only - } else { - set blims $blims_only_headerless - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] - } - } else { - set bmap $topmap - if {$do_show_header} { - set blims $blims_top - } else { - set blims $blims_top_headerless - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] - } - } - set rowframe [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] - set return_bodywidth [textblock::widthtopline $rowframe] ;#frame lines always same width - just look at top line - append part_body $rowframe \n - } else { - if {$r == $rmax} { - set joins [lremove $joins [lsearch $joins down*]] - set bmap $botmap - set blims $blims_bot - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts bottom$opt_posn] ] - } - } else { - set bmap $midmap - set blims $blims_mid ;#will only be reduced from boxlimits if -show_seps was processed above - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] - } - } - append part_body [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n - } - incr r - } - #return empty (zero content height) row if no rows - if {![llength $cells]} { - set joins [lremove $joins [lsearch $joins down*]] - #we need to know the width of the column to setup the empty cell properly - #even if no header displayed - we should take account of any defined column widths - set colwidth [my column_width $index_expression] - - if {$do_show_header} { - set blims $blims_only - } else { - append part_body \n - set blims $blims_only_headerless - } - #note that if show_edge is 0 - then for this empty line - we will not expect to see any bars - #This is because the frame with no data had vertical components made entirely of corner elements - #we could just append a newline when -show_edge is zero, but we want the correct width even when empty - for proper column joins when there are colspanned headers. - # - if {![tcl::dict::get $o_opts_table -show_edge]} { - #set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] - #append output [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n - append part_body [tcl::string::repeat " " $colwidth] \n - set return_bodywidth $colwidth - } else { - set emptyframe [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] - append part_body $emptyframe \n - set return_bodywidth [textblock::width $emptyframe] - } - } - #assert bodywidth is integer >=0 whether there are rows or not - - #trim only 1 newline - if {[tcl::string::index $part_body end] eq "\n"} { - set part_body [tcl::string::range $part_body 0 end-1] - } - set return_bodyheight [textblock::height $part_body] - #append output $part_body - - if {$opt_return eq "string"} { - if {$part_header ne ""} { - set output $part_header - if {$part_body ne ""} { - append output \n $part_body - } - } else { - set output $part_body - } - return $output - } else { - return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] - } - } - - method get_column_cells_by_index {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - set range "" - if {[tcl::dict::size $o_columndefs] > 0} { - set range "0..[expr {[tcl::dict::size $o_columndefs] -1}]" - } else { - set range empty - } - error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" - } - #assert cidx is integer >=0 - set num_header_rows [my header_count] - set cdef [tcl::dict::get $o_columndefs $cidx] - set headerlist [tcl::dict::get $cdef -headers] - set ansibase_col [tcl::dict::get $cdef -ansibase] - set textalign [tcl::dict::get $cdef -textalign] - switch -- $textalign { - left {set pad right} - right {set pad left} - default { - set pad "centre" ;#todo? - } - } - - set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] - set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] - - #set header_underlay $ansibase_header$cell_line_blank - - #set hdrwidth [my column_width_configured $cidx] - #set all_colspans [my header_colspans] - #we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric - set all_colspans [my header_colspans_numeric] - #JMN - #store configured widths so we don't look up for each header line - #set configured_widths [list] - #foreach c [tcl::dict::keys $o_columndefs] { - # #lappend configured_widths [my column_width $c] - # #we don't just want the width of the column in the body - or the headers will get truncated - # lappend configured_widths [my column_width_configured $c] - #} - - set output [tcl::dict::create] - tcl::dict::set output headers [list] - - set showing_vseps [my Showing_vseps] - for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} { - set hdr [lindex $headerlist $hrow] - set header_maxdataheight [my header_height $hrow] ;#from cached headerstates - set headerrow_colspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerrow_colspans $cidx] - - #set this_hdrwidth [lindex $configured_widths $cidx] - set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign - - set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] - set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] - set hval_lines [split $hdr \n] - set hval_lines [concat $hval_lines $hcell_lines] - set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top - set hval_block [::join $hval_lines \n] - set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] - tcl::dict::lappend output headers $hcell - } - - - #set colwidth [my column_width $cidx] - #set cell_line_blank [tcl::string::repeat " " $colwidth] - set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1] - set cell_line_blank [tcl::string::repeat " " $datawidth] - - - - set items [tcl::dict::get $o_columndata $cidx] - #puts "---> columndata $o_columndata" - - #set opt_row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - #set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase - - tcl::dict::set output cells [list];#ensure we return something for cells key if no items in list - set r 0 - foreach cval $items { - #todo move to row_height method ? - set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] - set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] - set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] - if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { - #an exact height is defined for the row - set rowh $rowdefminh - } else { - if {$rowdefminh eq ""} { - if {$rowdefmaxh eq ""} { - #both defs empty - set rowh $maxdataheight - } else { - set rowh [expr {min(1,$rowdefmaxh,$maxdataheight)}] - } - } else { - if {$rowdefmaxh eq ""} { - set rowh [expr {max($rowdefminh,$maxdataheight)}] - } else { - if {$maxdataheight < $rowdefminh} { - set rowh $rowdefminh - } else { - set rowh [expr {max($rowdefminh,$maxdataheight)}] - } - } - } - } - - set cell_lines [lrepeat $rowh $cell_line_blank] - #set cell_blank [join $cell_lines \n] - - - set cval_lines [split $cval \n] - set cval_lines [concat $cval_lines $cell_lines] - set cval_lines [lrange $cval_lines 0 $rowh-1] - set cval_block [::join $cval_lines \n] - - - set cell [textblock::pad $cval_block -width $datawidth -padchar " " -within_ansi 1 -which $pad] - #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] - tcl::dict::lappend output cells $cell - - incr r - } - return $output - } - method get_column_values_by_index {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - return [tcl::dict::get $o_columndata $cidx] - } - method debug {args} { - #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) - set defaults [tcl::dict::create\ - -usetables 1\ - ] - foreach {k v} $args { - switch -- $k { - -usetables {} - default { - error "table debug unrecognised option '$k'. Known options: [tcl::dict::keys $defaults]" - } - } - } - set opts [tcl::dict::merge $defaults $args] - set opt_usetables [tcl::dict::get $opts -usetables] - - puts stdout "rowdefs: $o_rowdefs" - puts stdout "rowstates: $o_rowstates" - #puts stdout "columndefs: $o_columndefs" - puts stdout "columndefs:" - if {!$opt_usetables} { - tcl::dict::for {k v} $o_columndefs { - puts " $k $v" - } - } else { - set t [textblock::class::table new] - $t add_column -headers "Col" - tcl::dict::for {col coldef} $o_columndefs { - foreach property [tcl::dict::keys $coldef] { - if {$property eq "-ansireset"} { - continue - } - $t add_column -headers $property - } - break - } - - #build our inner tables first so we can sync widths - set col_header_tables [tcl::dict::create] - set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths - tcl::dict::for {col coldef} $o_columndefs { - set row [list $col] - set colheaders [tcl::dict::get $coldef -headers] - #inner table probably overkill here ..but just as easy - set htable [textblock::class::table new] - $htable configure -show_header 1 -show_edge 0 -show_hseps 0 - $htable add_column -headers row - $htable add_column -headers text - $htable add_column -headers WxH - $htable add_column -headers span - set hnum 0 - set spans [tcl::dict::get $o_columndefs $col -header_colspans] - foreach h $colheaders s $spans { - lassign [textblock::size $h] _w width _h height - $htable add_row [list "$hnum " $h "${width}x${height}" $s] - incr hnum - } - $htable configure_column 0 -ansibase [a+ web-dimgray] - tcl::dict::set col_header_tables $col $htable - set colwidths [$htable column_widths] - set icol 0 - foreach w $colwidths { - if {$w > [tcl::dict::get $max_widths $icol]} { - tcl::dict::set max_widths $icol $w - } - incr icol - } - } - - #safe jumptable test - #dict for {col coldef} $o_columndefs {} - tcl::dict::for {col coldef} $o_columndefs { - set row [list $col] - #safe jumptable test - #dict for {property val} $coldef {} - tcl::dict::for {property val} $coldef { - switch -- $property { - -ansireset {continue} - -headers { - set htable [tcl::dict::get $col_header_tables $col] - tcl::dict::for {innercol maxw} $max_widths { - $htable configure_column $innercol -minwidth $maxw -blockalign left - } - lappend row [$htable print] - $htable destroy - } - default { - lappend row $val - } - } - } - $t add_row $row - } - - - - - $t configure -show_header 1 - puts stdout [$t print] - $t destroy - } - puts stdout "columnstates: $o_columnstates" - puts stdout "headerstates: $o_headerstates" - tcl::dict::for {k coldef} $o_columndefs { - if {[tcl::dict::exists $o_columndata $k]} { - set headerlist [tcl::dict::get $coldef -headers] - set coldata [tcl::dict::get $o_columndata $k] - set colinfo "rowcount: [llength $coldata]" - set allfields [concat $headerlist $coldata] - if {[llength $allfields]} { - set widest [tcl::mathfunc::max {*}[lmap v $allfields {textblock::width $v}]] - } else { - set widest 0 - } - append colinfo " widest of headers and data: $widest" - } else { - set colinfo "WARNING - no columndata record for column key '$k'" - } - puts stdout "column $k columndata info: $colinfo" - } - set result "" - set cols [list] - set max [expr {[tcl::dict::size $o_columndefs]-1}] - foreach c [tcl::dict::keys $o_columndefs] { - if {$c == 0} { - lappend cols [my get_column_by_index $c -position left] " " - } elseif {$c == $max} { - lappend cols [my get_column_by_index $c -position right] - } else { - lappend cols [my get_column_by_index $c -position inner] " " - } - } - append result [textblock::join -- {*}$cols] - return $result - } - #column width including headers - but without colspan consideration - method column_width_configured {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - #assert cidx is now >=0 integer within the range of defined columns - set cdef [tcl::dict::get $o_columndefs $cidx] - set defminw [tcl::dict::get $cdef -minwidth] - set defmaxw [tcl::dict::get $cdef -maxwidth] - if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { - #an exact width is defined for the column - no need to look at data width - set colwidth $defminw - } else { - #set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1] - set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - #set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1] - #set hwidest_singlespan ?? - set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - set widest [expr {max($hwidest,$bwidest)}] - #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. - #if so - a truncated line shouldn't be included in our width calculation - if {$defminw eq ""} { - if {$defmaxw eq ""} { - set colwidth $widest - } else { - set colwidth [expr {min($defmaxw,$widest)}] - } - } else { - if {$defmaxw eq ""} { - set colwidth [expr {max($defminw,$widest)}] - } else { - if {$widest < $defminw} { - set colwidth $defminw - } else { - if {$widest > $defmaxw} { - set colwidth $defmaxw - } else { - set colwidth [expr {max($defminw,$widest)}] - } - } - } - } - } - return $colwidth - } - - method column_width {index_expression} { - if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { - my calculate_column_widths -algorithm $o_column_width_algorithm - } - return [lindex $o_calculated_column_widths $index_expression] - } - method column_widths {} { - if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { - my calculate_column_widths -algorithm $o_column_width_algorithm - } - return $o_calculated_column_widths - } - - #width of a table includes borders and seps - #whereas width of a column refers to the borderless width (inner width) - method width {} { - #calculate width based on assumption frame verticals are 1-wide - review - what about custom unicode double-wide frame? - set colwidths [my column_widths] - set contentwidth [tcl::mathop::+ {*}$colwidths] - set twidth $contentwidth - if {[my Showing_vseps]} { - incr twidth [llength $colwidths] - incr twidth -1 - } - if {[tcl::dict::get $o_opts_table -show_edge]} { - incr twidth 2 - } - return $twidth - } - - #column *body* content width - method basic_column_width {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - #puts "===column_width $index_expression" - #assert cidx is now >=0 integer within the range of defined columns - set cdef [tcl::dict::get $o_columndefs $cidx] - set defminw [tcl::dict::get $cdef -minwidth] - set defmaxw [tcl::dict::get $cdef -maxwidth] - if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { - #an exact width is defined for the column - no need to look at data width - #review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header - set colwidth $defminw - } else { - #set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0] - set widest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. - #if so - a truncated line shouldn't be included in our width calculation - if {$defminw eq ""} { - if {$defmaxw eq ""} { - set colwidth $widest - } else { - set colwidth [expr {min($defmaxw,$widest)}] - } - } else { - if {$defmaxw eq ""} { - set colwidth [expr {max($defminw,$widest)}] - } else { - if {$widest < $defminw} { - set colwidth $defminw - } else { - if {$widest > $defmaxw} { - set colwidth $defmaxw - } else { - set colwidth [expr {max($defminw,$widest)}] - } - } - } - } - } - set configured_widths [list] - foreach c [tcl::dict::keys $o_columndefs] { - lappend configured_widths [my column_width_configured $c] - } - set header_colspans [my header_colspans] - set width_max $colwidth - set test_width $colwidth - set showing_vseps [my Showing_vseps] - set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - tcl::dict::for {h colspans} $header_colspans { - set spanc [lindex $colspans $cidx] - #set headers [tcl::dict::get $cdef -headers] - #set thiscol_widest_header 0 - #if {[llength $headers] > 0} { - # set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]] - #} - if {$spanc eq "1"} { - if {$thiscol_widest_header > $colwidth} { - set test_width [expr {max($thiscol_widest_header,$colwidth)}] - if {$defmaxw ne ""} { - set test_width [expr {min($colwidth,$defmaxw)}] - } - } - set width_max [expr {max($test_width,$width_max)}] - continue - } - if {$spanc eq "any" || $spanc > 1} { - set spanned [list] ;#spanned is other columns spanned - not including this one - set cnext [expr {$cidx +1}] - set spanlength [lindex $colspans $cnext] - while {$spanlength eq "0" && $cnext < [llength $colspans]} { - lappend spanned $cnext - incr cnext - set spanlength [lindex $colspans $cnext] - } - set others_width 0 - foreach col $spanned { - incr others_width [lindex $configured_widths $col] - if {$showing_vseps} { - incr others_width 1 - } - } - set total_spanned_width [expr {$width_max + $others_width}] - if {$thiscol_widest_header > $total_spanned_width} { - #this just allocates the extra space in the current column - which is not great. - #A proper algorithm for distributing width created by headers to all the spanned columns is needed. - #This is a tricky problem with multiple header lines and arbitrary spans. - #The calculation should probably be done on the table as a whole first and this function should just look up that result. - #Trying to calculate on a specific column only is unlikely to be easy or efficient. - set needed [expr {$thiscol_widest_header - $total_spanned_width}] - #puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)" - if {$defmaxw ne ""} { - set test_width [expr {min($colwidth+$needed,$defmaxw)}] - } else { - set test_width [expr {$colwidth + $needed}] - } - } - } - set width_max [expr {max($test_width,$width_max)}] - } - - #alternative to all the above shennanigans.. let the body cell data determine the size and just wrap the headers - #could also split the needed width amongst the spanned columns? configurable for whether cells expand? - set expand_first_column 1 - if {$expand_first_column} { - set colwidth $width_max - } - - #puts "---column_width $cidx = $colwidth" - return $colwidth - } - method Showing_vseps {} { - #review - show_seps and override mechanism for show_vseps show_hseps - document. - set seps [tcl::dict::get $o_opts_table -show_seps] - set vseps [tcl::dict::get $o_opts_table -show_vseps] - if {$seps eq ""} { - if {$vseps eq "" || $vseps} { - return true - } - } elseif {$seps} { - if {$vseps eq "" || $vseps} { - return true - } - } else { - if {$vseps ne "" && $vseps} { - return true - } - } - return false - } - - method column_datawidth {index_expression args} { - set opts [tcl::dict::create\ - -headers 0\ - -footers 0\ - -colspan unspecified\ - -data 1\ - -cached 1\ - ] - #NOTE: -colspan any is not the same as * - # - #-colspan is relevant to header/footer data only - foreach {k v} $args { - switch -- $k { - -headers - -footers - -colspan - -data - -cached { - tcl::dict::set opts $k $v - } - default { - error "column_datawidth unrecognised flag '$k'. Known flags: [tcl::dict::keys $opts]" - } - } - } - set opt_colspan [tcl::dict::get $opts -colspan] - switch -- $opt_colspan { - * - unspecified {} - any { - error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0 (use header_colspans_numeric to get actual spans)" - } - default { - if {![string is integer -strict $opt_colspan]} { - error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0" - } - } - } - - - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - - if {[tcl::dict::get $opts -cached]} { - set hwidest 0 - set bwidest 0 - set fwidest 0 - if {[tcl::dict::get $opts -headers]} { - if {$opt_colspan in {* unspecified}} { - set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - } else { - #this is not cached - # -- --- --- --- - set colheaders [tcl::dict::get $o_columndefs $cidx -headers] - set all_colspans_by_header [my header_colspans_numeric] - set hlist [list] - tcl::dict::for {hrow cspans} $all_colspans_by_header { - set s [lindex $cspans $cidx] - if {$s eq $opt_colspan} { - lappend hlist [lindex $colheaders $hrow] - } - } - if {[llength $hlist]} { - set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] - } else { - set hwidest 0 - } - # -- --- --- --- - } - } - if {[tcl::dict::get $opts -data]} { - set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - } - if {[tcl::dict::get $opts -footers]} { - #TODO! - #set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthfooterseen] - } - return [expr {max($hwidest,$bwidest,$fwidest)}] - } - - #assert cidx is >=0 integer in valid range of keys for o_columndefs - set values [list] - set hwidest 0 - if {[tcl::dict::get $opts -headers]} { - if {$opt_colspan in {* unspecified}} { - lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] - } else { - # -- --- --- --- - set colheaders [tcl::dict::get $o_columndefs $cidx -headers] - set all_colspans_by_header [my header_colspans_numeric] - set hlist [list] - tcl::dict::for {hrow cspans} $all_colspans_by_header { - set s [lindex $cspans $cidx] - if {$s eq $opt_colspan} { - lappend hlist [lindex $colheaders $hrow] - } - } - if {[llength $hlist]} { - set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] - } else { - set hwidest 0 - } - # -- --- --- --- - } - } - if {[tcl::dict::get $opts -data]} { - if {[tcl::dict::exists $o_columndata $cidx]} { - lappend values {*}[tcl::dict::get $o_columndata $cidx] - } - } - if {[tcl::dict::get $opts -footers]} { - lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] - } - if {[llength $values]} { - set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] - set widest [expr {max($valwidest,$hwidest)}] - } else { - set widest $hwidest - } - return $widest - } - #print1 uses basic column joining - useful for testing/debug especially with colspans - method print1 {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0 } - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set colposn 0 - set numposns [llength $cols] - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - lappend blocks [my get_column_by_index $c {*}$flags] - incr colposn - } - if {[llength $blocks]} { - return [textblock::join -- {*}$blocks] - } else { - return "No columns matched" - } - } - method columncalc_spans {allocmethod} { - set colwidths [tcl::dict::create] ;# to use tcl::dict::incr - set colspace_added [tcl::dict::create] - - set ordered_spans [tcl::dict::create] - tcl::dict::for {col spandata} [my spangroups] { - set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] - set minwidth [tcl::dict::get $o_columndefs $col -minwidth] - set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] - if {$minwidth ne ""} { - if {$dwidth < $minwidth} { - set dwidth $minwidth - } - } - if {$maxwidth ne ""} { - if {$dwidth > $maxwidth} { - set dwidth $maxwidth - } - } - tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered - tcl::dict::set colspace_added $col 0 - - set spanlengths [tcl::dict::get $spandata spanlengths] - foreach slen $spanlengths { - set spans [tcl::dict::get $spandata spangroups $slen] - set spans [lsort -index 7 -integer $spans] - foreach s $spans { - set hwidth [tcl::dict::get $s headerwidth] - set hrow [tcl::dict::get $s hrow] - set scol [tcl::dict::get $s startcol] - tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth - tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth - } - } - } - - #safe jumptable test - #dict for {spanid spandata} $ordered_spans {} - tcl::dict::for {spanid spandata} $ordered_spans { - lassign [split $spanid ,] startcol hrow - set memcols [tcl::dict::get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios - set colids [tcl::dict::keys $memcols] - set hwidth [tcl::dict::get $spandata headerwidth] - set num_cols_spanned [tcl::dict::size $memcols] - if {$num_cols_spanned == 1} { - set col [lindex $memcols 0] - set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] - if {$space_to_alloc > 0} { - set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] - if {$maxwidth ne ""} { - if {$maxwidth > [tcl::dict::get $colwidths $col]} { - set can_alloc [expr {$maxwidth - [tcl::dict::get $colwidths $col]}] - } else { - set can_alloc 0 - } - set will_alloc [expr {min($space_to_alloc,$can_alloc)}] - } else { - set will_alloc $space_to_alloc - } - if {$will_alloc} { - #tcl::dict::set colwidths $col $hwidth - tcl::dict::incr colwidths $col $will_alloc - tcl::dict::set colspace_added $col $will_alloc - } - #log! - #if {$will_alloc < $space_to_alloc} { - # #todo - debug only - # puts stderr "max width $maxwidth hit for col $col - cannot allocate extra [expr {$space_to_alloc - $will_alloc}]" - #} - } - } elseif {$num_cols_spanned > 1} { - set spannedwidth 0 - foreach col $colids { - incr spannedwidth [tcl::dict::get $colwidths $col] - } - set space_to_alloc [expr {$hwidth - $spannedwidth}] - if {[my Showing_vseps]} { - set sepcount [expr {$num_cols_spanned -1}] - incr space_to_alloc -$sepcount - } - #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added - switch -- $allocmethod { - least { - #add to least-expanded each time - #safer than method 1 - pretty balanced - if {$space_to_alloc > 0} { - for {set i 0} {$i < $space_to_alloc} {incr i} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] - foreach testcolid $ordered_all_colids { - if {$testcolid in $colids} { - #assert - we will always find a match - set colid $testcolid - break - } - } - tcl::dict::incr colwidths $colid - tcl::dict::incr colspace_added $colid - } - } - } - least_unmaxed { - #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth - #(we should be able to collapse column width to zero and have header colspans gracefully respond) - #add to least-expanded each time - #safer than method 1 - pretty balanced - if {$space_to_alloc > 0} { - for {set i 0} {$i < $space_to_alloc} {incr i} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] - set colid "" - foreach testcolid $ordered_all_colids { - set maxwidth [tcl::dict::get $o_columndefs $testcolid -maxwidth] - set can_alloc [expr {$maxwidth eq "" || $maxwidth > [tcl::dict::get $colwidths $testcolid]}] - if {$testcolid in $colids} { - if {$can_alloc} { - set colid $testcolid - break - } else { - #remove from future consideration in for loop - #log! - #puts stderr "max width $maxwidth hit for col $testcolid" - tcl::dict::unset colspace_added $testcolid - } - } - } - if {$colid ne ""} { - tcl::dict::incr colwidths $colid - tcl::dict::incr colspace_added $colid - } - } - } - } - all { - #adds space to all columns - not just those spanned - risk of underallocating and truncating some headers! - #probably not a good idea for tables with complex headers and spans - while {$space_to_alloc > 0} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_colids [tcl::dict::keys $ordered_colspace_added] - - foreach col $ordered_colids { - tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col - incr space_to_alloc -1 - if {$space_to_alloc == 0} { - break - } - } - } - - } - } - } - } - - set column_widths [tcl::dict::values $colwidths] - #todo - -maxwidth etc - set table_minwidth [tcl::dict::get $o_opts_table -minwidth] ;#min width including frame elements - if {[tcl::string::is integer -strict $table_minwidth]} { - set contentwidth [tcl::mathop::+ {*}$column_widths] - set twidth $contentwidth - if {[my Showing_vseps]} { - incr twidth [llength $column_widths] - incr twidth -1 - } - if {[tcl::dict::get $o_opts_table -show_edge]} { - incr twidth 2 - } - # - set shortfall [expr {$table_minwidth - $twidth}] - if {$shortfall > 0} { - set space_to_alloc $shortfall - while {$space_to_alloc > 0} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_colids [tcl::dict::keys $ordered_colspace_added] - - foreach col $ordered_colids { - tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col - incr space_to_alloc -1 - if {$space_to_alloc == 0} { - break - } - } - } - set column_widths [tcl::dict::values $colwidths] - } - - } - - return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] - } - - #spangroups keyed by column - method spangroups {} { - set column_count [tcl::dict::size $o_columndefs] - set spangroups [tcl::dict::create] - set headerwidths [tcl::dict::create] ;#key on col,hrow - foreach c [tcl::dict::keys $o_columndefs] { - tcl::dict::set spangroups $c [list spanlengths {}] - set spanlist [my column_get_spaninfo $c] - set index_spanlen_val 5 - set spanlist [lsort -index $index_spanlen_val -integer $spanlist] - set ungrouped $spanlist - - while {[llength $ungrouped]} { - set spanlen [lindex $ungrouped 0 $index_spanlen_val] - set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen] - set sgroup [list] - foreach p $spangroup_posns { - set spaninfo [lindex $ungrouped $p] - set hcol [tcl::dict::get $spaninfo startcol] - set hrow [tcl::dict::get $spaninfo hrow] - set header [lindex [tcl::dict::get $o_columndefs $hcol -headers] $hrow] - if {[tcl::dict::exists $headerwidths $hcol,$hrow]} { - set hwidth [tcl::dict::get $headerwidths $hcol,$hrow] - } else { - set hwidth [textblock::width $header] - tcl::dict::set headerwidths $hcol,$hrow $hwidth - } - lappend spaninfo headerwidth $hwidth - lappend sgroup $spaninfo - } - set spanlengths [tcl::dict::get $spangroups $c spanlengths] - lappend spanlengths $spanlen - tcl::dict::set spangroups $c spanlengths $spanlengths - tcl::dict::set spangroups $c spangroups $spanlen $sgroup - set ungrouped [lremove $ungrouped {*}$spangroup_posns] - } - } - return $spangroups - } - method column_get_own_spans {cidx} { - set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] - } - method column_get_spaninfo {cidx} { - set spans_by_header [my header_colspans] - set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] - set spaninfo [list] - set numcols [tcl::dict::size $o_columndefs] - #note that 'any' can occur in positions other than column 0 - meaning any remaining until next non-zero span - tcl::dict::for {hrow rawspans} $spans_by_header { - set thiscol_spanval [lindex $rawspans $cidx] - if {$thiscol_spanval eq "any" || $thiscol_spanval > 0} { - set spanstartcol $cidx ;#own column - if {$thiscol_spanval eq "any"} { - #scan right to first non-zero to get actual length of 'any' span - #REVIEW! - set spanlen 1 - for {set i [expr {$cidx+1}]} {$i < $numcols} {incr i} { - #abort at next any or number or empty string - if {[lindex $rawspans $i] ne "0"} { - break - } - incr spanlen - } - #set spanlen [expr {$numcols - $cidx}] - } else { - set spanlen $thiscol_spanval - } - } else { - #look left til we see an any or a non-zero value - for {set i $cidx} {$i > -1} {incr i -1} { - set s [lindex $rawspans $i] - if {$s eq "any" || $s > 0} { - set spanstartcol $i - if {$s eq "any"} { - #REVIEW! - #set spanlen [expr {$numcols - $i}] - set spanlen 1 - #now scan right to see how long the 'any' actually is - for {set j [expr {$i+1}]} {$j < $numcols} {incr j} { - if {[lindex $rawspans $j] ne "0"} { - break - } - incr spanlen - } - } else { - set spanlen $s - } - break - } - } - } - #assert - we should always find 1 answer for each header row - lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen] - } - return $spaninfo - } - method calculate_column_widths {args} { - set column_count [tcl::dict::size $o_columndefs] - - set opts [tcl::dict::create\ - -algorithm $o_column_width_algorithm\ - ] - foreach {k v} $args { - switch -- $k { - -algorithm { - tcl::dict::set opts $k $v - } - default { - error "Unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set opt_algorithm [tcl::dict::get $opts -algorithm] - #puts stderr "--- recalculating column widths -algorithm $opt_algorithm" - set known_algorithms [list basic simplistic span span2] - switch -- $opt_algorithm { - basic { - #basic column by column - This allocates extra space to first span/column as they're encountered. - #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans - #The header values can extend over some of the spanned columns - but not optimally so. - set o_calculated_column_widths [list] - for {set c 0} {$c < $column_count} {incr c} { - lappend o_calculated_column_widths [my basic_column_width $c] - } - } - simplistic { - #just uses the widest column data or header element. - #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column - #This is a conservative option potentially useful in testing/debugging. - set o_calculated_column_widths [list] - for {set c 0} {$c < $column_count} {incr c} { - lappend o_calculated_column_widths [my column_width_configured $c] - } - } - span { - #widest of smallest spans first method - #set calcresult [my columncalc_spans least] - set calcresult [my columncalc_spans least_unmaxed] - set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] - } - span2 { - #allocates more evenly - but truncates headers sometimes - set calcresult [my columncalc_spans all] - set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] - } - default { - error "calculate_column_widths unknown algorithm $opt_algorithm. Known algorithms: $known_algorithms" - } - } - #remember the last algorithm used - set o_column_width_algorithm $opt_algorithm - return $o_calculated_column_widths - } - method print2 {args} { - variable full_column_cache - set full_column_cache [tcl::dict::create] - - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set colposn 0 - set numposns [llength $cols] - set padwidth 0 - set table "" - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - #lappend blocks [my get_column_by_index $c {*}$flags] - #todo - only check and store in cache if table has header or footer colspans > 1 - if {[tcl::dict::exists $full_column_cache $c]} { - #puts "!!print used full_column_cache for $c" - set columninfo [tcl::dict::get $full_column_cache $c] - } else { - set columninfo [my get_column_by_index $c -return dict {*}$flags] - tcl::dict::set full_column_cache $c $columninfo - } - set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] - - if {$table eq ""} { - set table $nextcol - set height [textblock::height $table] ;#only need to get height once at start - } else { - set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] - set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $nextcol] - #JMN - - #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] - #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] - } - incr padwidth $bodywidth - incr colposn - } - - if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - - # using -startcolumn to do slightly less work - method print3 {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set numposns [llength $cols] - set colposn 0 - set padwidth 0 - set table "" - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - set columninfo [my get_column_by_index $c -return dict {*}$flags] - set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] - - if {$table eq ""} { - set table $nextcol - set height [textblock::height $table] ;#only need to get height once at start - } else { - set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -overflow 1 -experimental test_mode -transparent $TSUB $table $nextcol] - - #set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] - #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $nextcol] - #JMN - - #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] - #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] - } - incr padwidth $bodywidth - incr colposn - } - - if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - - #print headers and body using different join mechanisms - # using -startcolumn to do slightly less work - method print {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set numposns [llength $cols] - set colposn 0 - set padwidth 0 - set header_build "" - set body_blocks [list] - set headerheight 0 - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - set columninfo [my get_column_by_index $c -return dict {*}$flags] - #set nextcol [tcl::dict::get $columninfo column] - set bodywidth [tcl::dict::get $columninfo bodywidth] - set headerheight [tcl::dict::get $columninfo headerheight] - #set nextcol_lines [split $nextcol \n] - #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] - #set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n] - set nextcol_header [tcl::dict::get $columninfo header] - set nextcol_body [tcl::dict::get $columninfo body] - - if {$header_build eq "" && ![llength $body_blocks]} { - set header_build $nextcol_header - lappend body_blocks $nextcol_body - } else { - if {$headerheight > 0} { - set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -overflow 1 -experimental test_mode -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] - } - lappend body_blocks $nextcol_body - #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] - } - incr padwidth $bodywidth - incr colposn - } - if {![llength $body_blocks]} { - set body_build "" - } else { - #body blocks should not be ragged - so can use join_basic - set body_build [textblock::join_basic -- {*}$body_blocks] - } - if {$headerheight > 0} { - set table [tcl::string::cat $header_build \n $body_build] - } else { - set table $body_build - } - - if {[llength $cols]} { - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - method print_bodymatrix {} { - set m [my as_matrix] - $m format 2string - } - - #*** !doctools - #[list_end] - }] - #*** !doctools - # [list_end] [comment {- end enumeration provider_classes }] - #[list_end] [comment {- end itemized list textblock::class groupings -}] - } - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# -#Note: A textblock does not necessarily have lines the same length - either in number of characters or print-width -# -tcl::namespace::eval textblock { - tcl::namespace::eval cd { - #todo - save and restore existing tcl::namespace::export in case macros::cd has default exports in future - tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export *} - tcl::namespace::import ::term::ansi::code::macros::cd::* - tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} - } - proc spantest {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2] - $t configure_column 0 -header_colspans {3 4 5 any 2} - $t configure_column 2 -headers {"" "" "" "" c2span2_etc} - $t configure_column 2 -header_colspans {0 0 0 0 2} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - proc spantest1 {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers [list "span3-any longer than other span any" "1-span4\n2-span4 second line" "span-any short aligned?" "span5/5 longest etc blah 123" span2] - $t configure_column 0 -header_colspans {any 4 any 5 2} - $t configure_column 2 -headers {"" "" "" "" c2span2_etc} - $t configure_column 2 -header_colspans {0 0 0 0 2} - $t configure_column 3 -header_colspans {1 0 0 0 0} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - $t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs) - return $t - } - - #more complex colspans - proc spantest2 {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} - $t configure_column 0 -header_colspans {3 4 1 any 2} - $t configure_column 1 -header_colspans {0 0 2 0 0} - $t configure_column 2 -headers {"" "" "" "" c2span2} - $t configure_column 2 -header_colspans {0 0 0 0 2} - $t configure_column 3 -header_colspans {1 0 2 0 0} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - proc spantest3 {} { - set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] - $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1} - $t configure_column 0 -header_colspans {3 4 1 any 2 1} - $t configure_column 1 -header_colspans {0 0 4 0 0 1} - $t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"} - $t configure_column 2 -headers {"" "" "" "" "" c2span2} - $t configure_column 2 -header_colspans {0 0 0 0 1 2} - $t configure_column 4 -headers {"4" "444" "" "" "" "44"} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - - - - proc periodic {args} { - #For an impressive interactive terminal app (javascript) - # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_dict { - *proc -name textblock::periodic -help "A rudimentary periodic table - This is primarily a test of textblock::class::table" - - -return -default table\ - -choices {table tableobject}\ - -help "default choice 'table' returns the displayable table output" - -compact -default 1 -type boolean -help "compact true defaults: -show_vseps 0 -show_header 0 -show_edge 0" - -frame -default 1 -type boolean - -show_vseps -default "" -type boolean - -show_header -default "" -type boolean - -show_edge -default "" -type boolean - -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - *values -min 0 -max 0 - } $args] opts] - - set opt_return [tcl::dict::get $opts -return] - if {[tcl::dict::get $opts -forcecolour]} { - set fc forcecolour - } else { - set fc "" - } - - #examples ptable.com - set elements [list\ - 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ - 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ - 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ - 4 K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr\ - 5 Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe\ - 6 Cs Ba "" Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn\ - 7 Fr Ra "" Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og\ - " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ - "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ - "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ - ] - - set type_colours [list] - - set ecat [tcl::dict::create] - - set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] - set ansi [a+ {*}$fc web-black Web-gold] - set val [list ansi $ansi cat alkaline_earth] - foreach e $cat_alkaline_earth { - tcl::dict::set ecat $e $val - } - - set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - #set ansi [a+ {*}$fc web-black Web-lightgreen] - set ansi [a+ {*}$fc black Term-113] - set val [list ansi $ansi cat reactive_nonmetal] - foreach e $cat_reactive_nonmetal { - tcl::dict::set ecat $e $val - } - - set cat [list Li Na K Rb Cs Fr] - #set ansi [a+ {*}$fc web-black Web-Khaki] - set ansi [a+ {*}$fc black Term-lightgoldenrod2] - set val [list ansi $ansi cat alkali_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - #set ansi [a+ {*}$fc web-black Web-lightsalmon] - set ansi [a+ {*}$fc black Term-orange1] - set val [list ansi $ansi cat transition_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] - set val [list ansi $ansi cat post_transition_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list B Si Ge As Sb Te At] - #set ansi [a+ {*}$fc web-black Web-turquoise] - set ansi [a+ {*}$fc black Brightcyan] - set val [list ansi $ansi cat metalloids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] - set val [list ansi $ansi cat noble_gases] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] - set val [list ansi $ansi cat actinoids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - #set ansi [a+ {*}$fc web-black Web-tan] - set ansi [a+ {*}$fc black Term-tan] - set val [list ansi $ansi cat lanthanoids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set ansi [a+ {*}$fc web-black Web-whitesmoke] - set val [list ansi $ansi cat other] - foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { - tcl::dict::set ecat $e $val - } - - set elements1 [list] - set RST [a+] - foreach e $elements { - if {[tcl::dict::exists $ecat $e]} { - set ansi [tcl::dict::get $ecat $e ansi] - #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] - #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway - lappend elements1 $ansi$e - } else { - lappend elements1 $e - } - } - - set t [list_as_table -columns 19 -return tableobject $elements1] - #(defaults to show_hseps 0) - - #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options - - set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] - set c 0 - foreach h $header_0 { - $t configure_column $c -headers [list $h] -minwidth 2 - incr c - } - set ccount [$t column_count] - for {set c 0} {$c < $ccount} {incr c} { - $t configure_column $c -minwidth 3 - } - if {[tcl::dict::get $opts -compact]} { - #compact defaults - but let explicit arguments override - set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0] - } else { - set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1] - } - dict for {k v} $conf { - if {[dict get $opts $k] ne ""} { - dict set conf $k [dict get $opts $k] - } - } - $t configure {*}[dict get $conf] - - $t configure \ - -frametype_header light\ - -ansiborder_header [a+ {*}$fc brightwhite]\ - -ansibase_header [a+ {*}$fc Black]\ - -ansibase_body [a+ {*}$fc Black]\ - -ansiborder_body [a+ {*}$fc black]\ - -frametype block - - #-ansiborder_header [a+ {*}$fc web-white]\ - - if {$opt_return eq "table"} { - if {[dict get $opts -frame]} { - #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - set output [textblock::frame -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - } else { - set output [$t print] - } - $t destroy - return $output - } - return $t - } - - proc list_as_table {args} { - set argd [punk::args::get_dict [string map [list $::textblock::frametypes] { - -return -default table -choices {table tableobject} - -frametype -default "" -help "frame type: or dict for custom frame" - -show_edge -default "" -type boolean -help "show outer border of table" - -show_seps -default "" -type boolean - -show_vseps -default "" -type boolean -help "Show vertical table separators" - -show_hseps -default "" -type boolean -help "Show horizontal table separators - (default 0 if no existing -table supplied)" - -table -default "" -type string -help "existing table object to use" - -headers -default "" -help "list of header values. Must match number of columns" - -action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied - if append is chosen the new values will always start at the first column" - -columns -default "" -type integer -help "Number of table columns - Will default to 2 if not using an existing -table object" - *values - datalist -default {} -help "flat list of table cell values which will be wrapped based on -columns value" - }] $args] - set opts [dict get $argd opts] - set datalist [dict get $argd values datalist] - - set existing_table [dict get $opts -table] - set opt_columns [dict get $opts -columns] - #set opts [tcl::dict::create\ - # -return string\ - # -frametype \uFFEF\ - # -show_edge \uFFEF\ - # -show_seps \uFFEF\ - #] - #foreach {k v} $args { - # switch -- $k { - # -return - -show_edge - -show_seps - -frametype { - # tcl::dict::set opts $k $v - # } - # default { - # error "unrecognised option '$k'. Known options [tcl::dict::keys $opts]" - # } - # } - #} - - set count [llength $datalist] - - set is_new_table 0 - if {$existing_table ne ""} { - if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} { - error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])" - } - set t $existing_table - foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} { - if {[tcl::dict::get $opts $prop] ne ""} { - $t configure $prop [tcl::dict::get $opts $prop] - } - } - if {[dict get $opts -action] eq "replace"} { - $t row_clear - } - set cols [$t column_count] - if {[tcl::string::is integer -strict $opt_columns]} { - if {$opt_columns > $cols} { - set extra [expr {$opt_columns - $cols}] - for {set c 0} {$c < $extra} {incr c} { - $t add_column - } - } elseif {$opt_columns < $cols} { - #todo - auto add blank values in the datalist - error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported" - } - set cols [$t column_count] - } - } else { - set is_new_table 1 - if {[tcl::string::is integer -strict $opt_columns]} { - set cols $opt_columns - } else { - #review - set cols 2 ;#seems a reasonable default - } - #defaults for new table only - if {[tcl::dict::get $opts -frametype] eq ""} { - tcl::dict::set opts -frametype "light" - } - if {[tcl::dict::get $opts -show_edge] eq ""} { - tcl::dict::set opts -show_edge 1 - } - if {[tcl::dict::get $opts -show_seps] eq ""} { - tcl::dict::set opts -show_seps 1 - } - if {[tcl::dict::get $opts -show_vseps] eq ""} { - tcl::dict::set opts -show_vseps 1 - } - if {[tcl::dict::get $opts -show_hseps] eq ""} { - tcl::dict::set opts -show_hseps 0 - } - set headers {} - set show_header 0 - if {[tcl::dict::get $opts -headers] ne ""} { - set headers [dict get $opts -headers] - if {[llength $headers] ne $cols} { - error "list_as_table number of headers ([llength $headers]) must match number of columns ($cols)" - } - set show_header 1 - } - - set t [textblock::class::table new\ - -show_header $show_header\ - -show_edge [tcl::dict::get $opts -show_edge]\ - -frametype [tcl::dict::get $opts -frametype]\ - -show_seps [tcl::dict::get $opts -show_seps]\ - -show_vseps [tcl::dict::get $opts -show_vseps]\ - -show_hseps [tcl::dict::get $opts -show_hseps]\ - ] - if {[llength $headers]} { - for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [lindex $headers $c] - } - } else { - for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [list $c] - } - } - } - - set full_rows [expr {$count / $cols}] - set last_items [expr {$count % $cols}] - - - set rowdata [list] - set row [list] - set i 0 - if {$full_rows > 0} { - for {set r 0} {$r < $full_rows} {incr r} { - set j [expr {$i + ($cols -1)}] - set row [lrange $datalist $i $j] - incr i $cols - lappend rowdata $row - } - } - if {$last_items > 0} { - set idx [expr {$last_items -1}] - lappend rowdata [lrange $datalist end-$idx end] - } - foreach row $rowdata { - set shortfall [expr {$cols - [llength $row]}] - if {$shortfall > 0} { - set row [concat $row [lrepeat $shortfall ""]] - } - $t add_row $row - } - #puts stdout $rowdata - if {[tcl::dict::get $opts -return] eq "table"} { - set result [$t print] - if {$is_new_table} { - $t destroy - } - return $result - } else { - return $t - } - } - #return a homogenous block of characters - ie lines all same length, all same character - #printing-width in terminal columns is not necessarily same as blockwidth even if a single char is passed (could be full-width unicode character) - #This can have ansi SGR codes - but to repeat blocks containing ansi-movements, the block should first be rendered to a static output with something like overtype::left - proc block {blockwidth blockheight {char " "}} { - if {$blockwidth < 0} { - error "textblock::block blockwidth must be an integer greater than or equal to zero" - } - if {$blockheight <= 0} { - error "textblock::block blockheight must be a positive integer" - } - if {$char eq ""} {return ""} - #using tcl::string::length is ok - if {[tcl::string::length $char] == 1} { - set row [tcl::string::repeat $char $blockwidth] - set mtrx [lrepeat $blockheight $row] - return [::join $mtrx \n] - } else { - set charblock [tcl::string::map [list \r\n \n] $char] - if {[tcl::string::last \n $charblock] >= 0} { - if {$blockwidth > 1} { - #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) - set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] - } else { - set row $charblock - } - } else { - set row [tcl::string::repeat $char $blockwidth] - } - set mtrx [lrepeat $blockheight $row] - return [::join $mtrx \n] - } - } - proc testblock {size {colour ""}} { - if {$size <1 || $size > 15} { - error "textblock::testblock only sizes between 1 and 15 inclusive supported" - } - set rainbow_list [list] - lappend rainbow_list {30 47} ;#black White - lappend rainbow_list {31 46} ;#red Cyan - lappend rainbow_list {32 45} ;#green Purple - lappend rainbow_list {33 44} ;#yellow Blue - lappend rainbow_list {34 43} ;#blue Yellow - lappend rainbow_list {35 42} ;#purple Green - lappend rainbow_list {36 41} ;#cyan Red - lappend rainbow_list {37 40} ;#white Black - lappend rainbow_list {black Yellow} - lappend rainbow_list red - lappend rainbow_list green - lappend rainbow_list yellow - lappend rainbow_list blue - lappend rainbow_list purple - lappend rainbow_list cyan - lappend rainbow_list {white Red} - - set rainbow_direction "horizontal" - set vpos [lsearch $colour vertical] - if {$vpos >= 0} { - set rainbow_direction vertical - set colour [lremove $colour $vpos] - } - set hpos [lsearch $colour horizontal] - if {$hpos >=0} { - #horizontal is the default and superfluous but allowed for symmetry - set colour [lremove $colour $hpos] - } - - - - set chars [concat [punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] - if {"noreset" in $colour} { - set RST "" - } else { - set RST [a] - } - if {"rainbow" in $colour && $rainbow_direction eq "vertical"} { - #column first - colour change each column - set c [::join $charsubset \n] - - set clist [list] - for {set i 0} {$i <$size} {incr i} { - set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] - set ansi [a+ {*}$colour2] - - set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] - lappend clist ${ansicode}$c$RST - } - if {"noreset" in $colour} { - return [textblock::join_basic -ansiresets 0 -- {*}$clist] - } else { - return [textblock::join_basic -- {*}$clist] - } - } elseif {"rainbow" in $colour} { - #direction must be horizontal - set block "" - for {set r 0} {$r < $size} {incr r} { - set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] - set ansi [a+ {*}$colour2] - set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] - set row "$ansicode" - foreach c $charsubset { - append row $c - } - append row $RST - append block $row\n - } - set block [tcl::string::trimright $block \n] - return $block - } else { - #row first - - set rows [list] - foreach ch $charsubset { - lappend rows [tcl::string::repeat $ch $size] - } - set block [::join $rows \n] - if {$colour ne ""} { - set block [a+ {*}$colour]$block$RST - } - return $block - } - } - interp alias {} testblock {} textblock::testblock - - #todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table - proc width {textblock} { - #backspaces, vertical tabs ? - if {$textblock eq ""} { - return 0 - } - #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - if {[punk::ansi::ta::detect $textblock]} { - #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) - set textblock [punk::ansi::ansistripraw $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } - return [punk::char::ansifreestring_width $textblock] - } - #when we know the block is uniform in width - just examine topline - proc widthtopline {textblock} { - set firstnl [tcl::string::first \n $textblock] - if {$firstnl >= 0} { - set tl [tcl::string::range $textblock 0 $firstnl] - } else { - set tl $textblock - } - if {[punk::ansi::ta::detect $tl]} { - set tl [punk::ansi::ansistripraw $tl] - } - return [punk::char::ansifreestring_width $tl] - } - #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. - proc string_length_line_max textblock { - tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - } - proc string_length_line_min textblock { - tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - } - proc height {textblock} { - #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le - #empty string still has height 1 (at least for left-right/right-left languages) - - #vertical tab on a proper terminal should move directly down. - #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) - - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - } - #MAINTENANCE - same as overtype::blocksize? - proc size {textblock} { - if {$textblock eq ""} { - return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings - } - #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests - if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::ansistripraw $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set width [punk::char::ansifreestring_width $textblock] - } - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - #our concept of block-height is likely to be different to other line-counting mechanisms - set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - - return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height - } - #must be able to handle block as string with or without newlines - #if no newlines - attempt to treat as a list - #must handle whitespace-only string,list elements, and/or lines. - #reviewing 2024 - this seems like too much magic! - proc width1 {block} { - if {$block eq ""} { - return 0 - } - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set block [textutil::tabify::untabify2 $block $tw] - if {[tcl::string::last \n $block] >= 0} { - return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]] - } - if {[catch {llength $block}]} { - return [::punk::char::string_width [ansistrip $block]] - } - if {[llength $block] == 0} { - #could be just a whitespace string - return [tcl::string::length $block] - } - return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]] - } - - #we shouldn't make textblock depend on the punk pipeline system - #pipealias ::textblock::padleft .= {list $input [tcl::string::repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- |? ?-which right|left|centre? ?-width auto|? ?-within_ansi 1|0?" - foreach {k v} $args { - switch -- $k { - -padchar - -which - -width - -overflow - -within_ansi { - tcl::dict::set opts $k $v - } - default { - error "textblock::pad unrecognised option '$k'. Usage: $usage" - } - } - } - # -- --- --- --- --- --- --- --- --- --- - set padchar [tcl::dict::get $opts -padchar] - #if padchar width (screen width) > 1 - length calculations will not be correct - #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map - #The caller may also use ansi within the padchar - although it's unlikely to be efficient. - # -- --- --- --- --- --- --- --- --- --- - set known_whiches [list l left r right c center centre] - set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] - switch -- $opt_which { - center - centre - c { - set which c - } - left - l { - set which l - } - right - r { - set which r - } - default { - error "textblock::pad unrecognised value for -which option. Known values $known_whiches" - } - } - # -- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - switch -- $opt_width { - "" - auto { - set width auto - } - default { - if {![tcl::string::is integer -strict $opt_width] || $opt_width < 0} { - error "textblock::pad -width must be an integer >=0" - } - set width $opt_width - } - } - # -- --- --- --- --- --- --- --- --- --- - set opt_withinansi [tcl::dict::get $opts -within_ansi] - switch -- $opt_withinansi { - 0 - 1 {} - default { - set opt_withinansi 2 - } - } - # -- --- --- --- --- --- --- --- --- --- - - set datawidth [textblock::width $block] - if {$width eq "auto"} { - set width $datawidth - } - - set lines [list] - - set padcharsize [punk::ansi::printing_length $padchar] - set pad_has_ansi [punk::ansi::ta::detect $padchar] - if {$block eq ""} { - #we need to treat as a line - set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - #TODO - #review - what happens when padchar has ansi, or the width would split a double-wide unicode char? - #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) - #we should use overtype with suitable replacement char (space?) for chopped double-wides - if {!$pad_has_ansi} { - return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] - } else { - set base [tcl::string::repeat " " $width] - return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - } - - #review - tcl format can only pad with zeros or spaces? - #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - if 0 { - #review - surprisingly, this doesn't seem to be a performance win - #No detectable diff on small blocks - slightly worse on large blocks - if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { - #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position - #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. - set block [tcl::string::map [list \r\n \n] $block] - if {$which eq "l"} { - set fmt "%+${padchar}*s" - } else { - set fmt "%-${padchar}*s" - } - foreach ln [split $block \n] { - #set lnwidth [punk::char::ansifreestring_width $ln] - set lnwidth [punk::char::grapheme_width_cached $ln] - set lnlen [tcl::string::length $ln] - set diff [expr $lnwidth - $lnlen] - #we need trickwidth to get format to pad a string with a different terminal width compared to string length - set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) - lappend lines [format $fmt $trickwidth $ln] - } - return [::join $lines \n] - } - } - - #todo? special case trailing double-reset - insert between resets? - set lnum 0 - if {[punk::ansi::ta::detect $block]} { - set parts [punk::ansi::ta::split_codes $block] - } else { - #single plaintext part - set parts [list $block] - } - set line_chunks [list] - set line_len 0 - set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad - foreach {pt ansi} $parts { - if {$pt ne ""} { - set has_nl [expr {[tcl::string::last \n $pt]>=0}] - if {$has_nl} { - set pt [tcl::string::map [list \r\n \n] $pt] - set partlines [split $pt \n] - } else { - set partlines [list $pt] - } - set last [expr {[llength $partlines]-1}] - set p 0 - foreach pl $partlines { - lappend line_chunks $pl - #incr line_len [punk::char::ansifreestring_width $pl] - incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW - if {$p != $last} { - #do padding - set missing [expr {$width - $line_len}] - if {$missing > 0} { - #commonly in a block - many lines will have the same pad - cache based on missing - - #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars - if {[tcl::dict::exists $pad_cache $missing]} { - set pad [tcl::dict::get $pad_cache $missing] - } else { - set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { - set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] - } else { - set base [tcl::string::repeat " " $missing] - set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - dict set pad_cache $missing $pad - } - switch -- $which-$opt_withinansi { - r-0 { - lappend line_chunks $pad - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { - lappend line_chunks $pad - } - l-0 { - set line_chunks [linsert $line_chunks 0 $pad] - } - l-1 { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - l-2 { - if {$lnum == 0} { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - } - } - lappend lines [::join $line_chunks ""] - set line_chunks [list] - set line_len 0 - incr lnum - } - incr p - } - } else { - #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes - lappend line_chunks "" - } - #don't let trailing empty ansi affect the line_chunks length - if {$ansi ne ""} { - lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? - } - } - #pad last line - set missing [expr {$width - $line_len}] - if {$missing > 0} { - if {[tcl::dict::exists $pad_cache $missing]} { - set pad [tcl::dict::get $pad_cache $missing] - } else { - set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { - set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] - } else { - set base [tcl::string::repeat " " $missing] - set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] - } - } - #set pad [tcl::string::repeat $padchar $missing] - switch -- $which-$opt_withinansi { - r-0 { - lappend line_chunks $pad - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - #lappend line_chunks $pad - } - l-0 { - #if {[lindex $line_chunks 0] eq ""} { - # set line_chunks [linsert $line_chunks 2 $pad] - #} else { - # set line_chunks [linsert $line_chunks 0 $pad] - #} - set line_chunks [linsert $line_chunks 0 $pad] - } - l-1 { - #set line_chunks [linsert $line_chunks 0 $pad] - set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] - } - l-2 { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - } - lappend lines [::join $line_chunks ""] - return [::join $lines \n] - } - - #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single - #resulting list is no longer a valid ansisplit list - proc _insert_before_text_or_last_ansi {str ansisplits} { - if {[llength $ansisplits] == 1} { - #ansisplits was a split on plaintext only - return [list $str [lindex $ansisplits 0]] - } elseif {[llength $ansisplits] == 0} { - return [list $str] - } - if {[llength $ansisplits] %2 != 1} { - error "_insert_before_text_or_last_ansi ansisplits list is not a valid resultlist from an ansi split - must be odd number of elements pt,ansi,pt,ansi...pt" - } - set out [list] - set i 0 - set i_last_code [expr {[llength $ansisplits]-3}] ;#would normally be -2 - but our i is jumping to each pt - not every element - foreach {pt code} $ansisplits { - if {$pt ne ""} { - return [lappend out $str {*}[lrange $ansisplits $i end]] - } - if {$i == $i_last_code} { - return [lappend out $str {*}[lrange $ansisplits $i end]] - } - #code being empty can only occur when we have reached last pt - #we have returned by then. - lappend out $code - incr i 2 - } - error "_insert_before_text_or_last_ansi failed on input str:[ansistring VIEW $str] ansisplits:[ansistring VIEW $ansisplits]" - } - proc pad_test {block} { - set width [textblock::width $block] - set padtowidth [expr {$width + 10}] - set left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - set left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - set left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - set right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - set right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - set right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] - - set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] - - set t [textblock::list_as_table -columns 3 -return tableobject $testlist] - $t configure_column 0 -headers [list "ansi"] - $t configure_column 1 -headers [list "Left"] - $t configure_column 2 -headers [list "Right"] - $t configure -show_header 1 - puts stdout [$t print] - return $t - } - - proc pad_test_blocklist {blocklist args} { - set opts [tcl::dict::create\ - -description ""\ - -blockheaders ""\ - ] - foreach {k v} $args { - switch -- $k { - -description - -blockheaders { - tcl::dict::set opts $k $v - } - default { - error "pad_test_blocklist unrecognised option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set opt_blockheaders [tcl::dict::get $opts -blockheaders] - set bheaders [tcl::dict::create] - if {$opt_blockheaders ne ""} { - set b 0 - foreach h $opt_blockheaders { - if {$b < [llength $blocklist]} { - tcl::dict::set bheaders $b $h - } - incr b - } - } - - set b 0 - set blockinfo [tcl::dict::create] - foreach block $blocklist { - set width [textblock::width $block] - tcl::dict::set blockinfo $b width $width - set padtowidth [expr {$width + 3}] - tcl::dict::set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - tcl::dict::set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - tcl::dict::set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - tcl::dict::set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - tcl::dict::set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - tcl::dict::set blockinfo $b right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] - incr b - } - - set r0 [list "0"] - set r1 [list "1"] - set r2 [list "2"] - set r3 [list "column\ncolours"] - - #1 - #test without table padding - #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering - #(basically a mechanism to add extra resets at start and end of each line) - #dict for {b bdict} $blockinfo { - # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] - # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] - # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] - #} - - #2 - the more useful one? - tcl::dict::for {b bdict} $blockinfo { - lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] - lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] - lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] - lappend r3 "" "" - } - - set rows [concat $r0 $r1 $r2 $r3] - - set column_ansi [a+ web-white Web-Gray] - - set t [textblock::list_as_table -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows] - $t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi - set col 1 - tcl::dict::for {b bdict} $blockinfo { - if {[tcl::dict::exists $bheaders $b]} { - set hdr [tcl::dict::get $bheaders $b] - } else { - set hdr "Block $b" - } - $t configure_column $col -headers [list $hdr "Left"] -minwidth [expr {$padtowidth + 2}] - $t configure_column $col -header_colspans 2 -ansibase $column_ansi - incr col - $t configure_column $col -headers [list "-" "Right"] -minwidth [expr {$padtowidth + 2}] -ansibase $column_ansi - incr col - } - $t configure -show_header 1 - puts stdout [$t print] - return $t - } - proc pad_example {} { - set headers [list] - set blocks [list] - - lappend blocks "[textblock::testblock 4 rainbow]" - lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" - - lappend blocks "[textblock::testblock 4 rainbow][a]" - lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" - - lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" - lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}]" - lappend headers "rainbow 4x4\nno line resets\nnothing trailing" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" - lappend headers "rainbow 4x4\nno line resets\ntrailing reset" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" - lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" - - set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] - } - proc pad_example2 {} { - set headers [list] - set blocks [list] - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" - - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" - - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" - - set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] - } - - - #playing with syntax - - # pipealias ::textblock::join_width .= {list $lhs [tcl::string::repeat " " $w1] $rhs [tcl::string::repeat " " $w2]} {| - # /2,col1/1,col2/3 - # >} punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| - # >} punk::lib::list_as_lines punk . rhs] - set pright [>punk . lhs] - set prightair [>punk . lhs_air] - set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] - set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] - set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] - set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] - set RST [a] - set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] - set punks [textblock::join -- $pleft $pright] - set pleft_greenb $greenb$pleft$RST - set pright_redb $redb$pright$RST - set prightair_cyanb $cyanb$prightair$RST - set cpunks [textblock::join -- $pleft_greenb $pright_redb] - set out "" - append out $punks \n - append out $cpunks \n - append out [textblock::join -- $punks $cpunks] \n - set 2frames_a [textblock::join -- [textblock::frame $cpunks] [textblock::frame $punks]] - append out $2frames_a \n - set 2frames_b [textblock::join -- [textblock::frame -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -ansiborder $greenb -title "fancypunks" $cpunks]] - append out [textblock::frame -title "punks" $2frames_b\n$RST$2frames_a] \n - set fancy [overtype::right [overtype::left [textblock::frame -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nL\nI\nF\nE"] - set spantable [[spantest] print] - append out [textblock::join -- $fancy " " $spantable] \n - #append out [textblock::frame -title gr $gr0] - append out [textblock::periodic -forcecolour $opt_forcecolour] - return $out - } - - proc example3 {{text "test\netc\nmore text"}} { - package require patternpunk - .= textblock::join -- [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join -- " " |> .=>1 textblock::join -- $text |> .=>1 textblock::join -- [>punk . rhs] |> .=>1 textblock::join -- [punk::lib::list_as_lines -- [lrepeat 7 " | "]] - } - proc example2 {{text "test\netc\nmore text"}} { - package require patternpunk - .= textblock::join\ - --\ - [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7 8]]\ - [>punk . lhs]\ - " "\ - $text\ - [>punk . rhs]\ - [punk::lib::list_as_lines -- [lrepeat 8 " | "]] - } - proc table {args} { - upvar ::textblock::class::opts_table_defaults toptdefaults - set defaults [tcl::dict::create\ - -rows [list]\ - -headers [list]\ - -return string\ - ] - - - set defaults [tcl::dict::merge $defaults $toptdefaults] ;# -title -frametype -show_header etc - set opts [tcl::dict::merge $defaults $args] - # -- --- --- --- - set opt_return [tcl::dict::get $opts -return] - set opt_rows [tcl::dict::get $opts -rows] - set opt_headers [tcl::dict::get $opts -headers] - # -- --- --- --- - set topts [tcl::dict::create] - set toptkeys [tcl::dict::keys $toptdefaults] - tcl::dict::for {k v} $opts { - if {$k in $toptkeys} { - tcl::dict::set topts $k $v - } - } - set t [textblock::class::table new {*}$topts] - - foreach h $opt_headers { - $t add_column -headers [list $h] - } - if {[$t column_count] == 0} { - if {[llength $opt_rows]} { - set r0 [lindex $opt_rows 0] - foreach c $r0 { - $t add_column - } - } - } - foreach r $opt_rows { - $t add_row $r - } - - - - if {$opt_return eq "string"} { - set result [$t print] - $t destroy - return $result - } else { - return $t - } - } - - variable frametypes - set frametypes [list light heavy arc double block block1 block2 ascii altg] - #class::table needs to be able to determine valid frametypes - proc frametypes {} { - variable frametypes - return $frametypes - } - proc frametype {f} { - #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - switch -- $f { - light - heavy - arc - double - block - block1 - block2 - ascii - altg { - return [tcl::dict::create category predefined type $f] - } - default { - set is_custom_dict_ok 1 - if {[llength $f] %2 == 0} { - #custom dict may leave out keys - but cannot have unknown keys - foreach {k v} $f { - switch -- $k { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - default { - #k not in custom_keys - set is_custom_dict_ok 0 - break - } - } - } - } else { - set is_custom_dict_ok 0 - } - if {!$is_custom_dict_ok} { - error "frame option -type must be one of known types: $textblock::frametypes or a dictionary with any of keys hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - set custom_frame [tcl::dict::merge $default_custom $f] - return [tcl::dict::create category custom type $custom_frame] - } - } - } - variable framedef_cache [tcl::dict::create] - proc framedef {args} { - #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. - #e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy. - #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. - #the arc set can't even join to itself e.g with curved equivalents of T-like shapes - - #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. - variable framedef_cache - set cache_key $args - if {[tcl::dict::exists $framedef_cache $cache_key]} { - return [tcl::dict::get $framedef_cache $cache_key] - } - set argopts [lrange $args 0 end-1] - set f [lindex $args end] - - #here we avoid the punk::args usage on the happy path, even though punk::args is fairly fast, in favour of an even faster literal switch on the happy path - #this means we have some duplication in where our flags/opts are defined: here in opts, and in spec below to give nicer error output without affecting performance. - #It also means we can't specify checks on the option types etc - set opts [tcl::dict::create\ - -joins ""\ - -boxonly 0\ - ] - set bad_option 0 - foreach {k v} $argopts { - switch -- $k { - -joins - -boxonly { - tcl::dict::set opts $k $v - } - default { - set bad_option - break - } - } - } - if {[llength $args] % 2 == 0 || $bad_option} { - #no framedef supplied, or unrecognised opt seen - set spec [string map [list $::textblock::frametypes] { - *proc -name textblock::framedef - -joins -default "" -help "List of join directions, any of: up down left right - or those combined with another frametype e.g left-heavy down-light" - -boxonly -default 0 -help "-boxonly true restricts results to the corner,vertical and horizontal box elements - It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj" - *values -min 1 -max 1 - frametype -help "name from the predefined frametypes: - or an adhoc - }] - append spec \n "frametype -help \"A predefined \"" - punk::args::get_dict $spec $args - return - } - - set joins [tcl::dict::get $opts -joins] - set boxonly [tcl::dict::get $opts -boxonly] - - - #sorted order down left right up - #1 x choose 4 - #4 x choose 3 - #6 x choose 2 - #4 x choose 1 - #15 combos - - set join_directions [list] - #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode - #e.g down-light, up-heavy - set join_targets [tcl::dict::create left "" down "" right "" up ""] - foreach jt $joins { - lassign [split $jt -] direction target - if {$target ne ""} { - tcl::dict::set join_targets $direction $target - } - lappend join_directions $direction - } - set join_directions [lsort -unique $join_directions] - set do_joins [::join $join_directions _] - - - switch -- $f { - "altg" { - #old style ansi escape sequences with alternate graphics page G0 - set hl [cd::hl] - set hlt $hl - set hlb $hl - set vl [cd::vl] - set vll $vl - set vlr $vl - set tlc [cd::tlc] - set trc [cd::trc] - set blc [cd::blc] - set brc [cd::brc] - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - #No join targets available to join altg to other box styles - switch -- $do_joins { - down { - #1 - set blc [punk::ansi::g0 t] ;#(ltj) - set brc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } left { - #2 - set tlc [punk::ansi::g0 w] ;#(ttj) - set blc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - right { - #3 - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 v] ;#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - up { - #4 - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - } - down_left { - #5 - set blc [punk::ansi::g0 n] ;#(fwj) - set tlc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - down_right { - #6 - set blc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 n] ;#(fwj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_up { - #7 - set blc [punk::ansi::g0 t] ;#(ltj) - set brc [punk::ansi::g0 u] ;#(rtj) - - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set hltj [punk::ansi::g0 v];#(btj) - } - left_right { - #8 - #from 2 - set tlc [punk::ansi::g0 w] ;#(ttj) - set blc [punk::ansi::g0 v] ;#(btj) - #from3 - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - left_up { - #9 - set tlc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 u] ;#(rtj) - set blc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - right_up { - #10 - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 v] ;#(btj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_left_right { - #11 - set blc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 w] ;#(ttj) - set tlc [punk::ansi::g0 w] ;#(ttj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - down_left_up { - #12 - set tlc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 u] ;#(rtj) - set brc [punk::ansi::g0 u] ;#(rtj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - down_right_up { - #13 - set tlc [punk::ansi::g0 t] ;#(ltj) - set blc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - left_right_up { - #14 - set tlc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 v] ;#(btj) - set brc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_left_right_up { - #15 - set tlc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - } - - - } - "ascii" { - set hl - - set hlt - - set hlb - - set vl | - set vll | - set vlr | - set tlc + - set trc + - set blc + - set brc + - #horizontal and vertical bar joins - #set hltj $hlt - #set hlbj $hlb - #set vllj $vll - #set vlrj $vlr - #ascii + is small - can reasonably be considered a join to anything? - set hltj + - set hlbj + - set vllj + - set vlrj + - #our corners are all + already - so we won't do anything for directions or targets - - } - "light" { - #unicode box drawing set - set hl [punk::char::charshort boxd_lhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_lv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ldr] - set trc [punk::char::charshort boxd_ldl] - set blc [punk::char::charshort boxd_lur] - set brc [punk::char::charshort boxd_lul] - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #15 combos - #sort order: down left right up - #ltj,rtj,ttj,btj e.g left T junction etc. - #Look at from the perspective of a frame/table outline with a clean border and arms pointing inwards - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'light' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - light { - set target$dir light - } - ascii - altg - arc { - set target$dir light - } - heavy { - set target$dir $target - } - default { - set target$dir other - } - } - } - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - heavy { - set blc [punk::char::charshort boxd_dhrul] ;#\u251f down hieavy and right up light (ltj) - set brc \u2527 ;#boxd_dhlul down heavy and left up light (rtj) - set hlbj \u2530 ;# down heavy (ttj) - } - light { - set blc \u251c ;#[punk::char::charshort boxd_lvr] light vertical and right (ltj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set hlbj \u252c ;# (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - heavy { - set tlc \u252d ;# Left Heavy and Right Down Light (ttj) - set blc \u2535 ;# Left Heavy and Right Up Light (btj) - set vllj \u2525 ;# left heavy (rtj) - } - light { - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set vllj \u2524 ;# (rtj) - } - } - } - right { - #3 - switch -- $targetright { - heavy { - set trc \u252e ;#Right Heavy and Left Down Light (ttj) - set brc \u2536 ;#Right Heavy and Left up Light (btj) - set vlrj \u251d;#right heavy (ltj) - } - light { - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set vlrj \u251c;# (ltj) - } - } - } - up { - #4 - switch -- $targetup { - heavy { - set tlc \u251e ;#up heavy (ltj) - set trc \u2526 ;#up heavy (rtj) - } - light { - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - other-light { - set blc \u2534 ;#(btj) - set tlc \u252c ;#(ttj) - #brc - default corner - set vllj \u2524 ;# (rtj) - } - other-other { - #default corners - } - other-heavy { - set blc \u2535 ;# heavy left (btj) - set tlc \u252d ;#heavy left (ttj) - #brc default corner - set vllj \u2525 ;# heavy left (rtj) - } - heavy-light { - set blc \u2541 ;# heavy down (fwj) - set tlc \u252c ;# light (ttj) - set brc \u2527 ;# heavy down (rtj) - set vllj \u2524 ;# (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - heavy-other { - set blc \u251f ;#heavy down (ltj) - #tlc - default corner - set brc \u2527 ;#heavy down (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - heavy-heavy { - set blc \u2545 ;#heavy down and left (fwj) - set tlc \u252d ;#heavy left (ttj) - set brc \u2527 ;#heavy down (rtj) - set vllj \u2525 ;# heavy left (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - light-light { - set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set tlc \u252c ;# boxd_ldhz (ttj) - set brc \u2524 ;# boxd_lvl light vertical and left(rtj) - set vllj \u2524 ;# (rtj) - set hlbj \u252c ;# (ttj) - } - light-other { - set blc \u251c ;# (ltj) - #tlc - default corner - set brc \u2524 ;# boxd_lvl (rtj) - set hlbj \u252c ;# (ttj) - } - light-heavy { - set blc \u253d ;# heavy left (fwj) - set tlc \u252d ;# heavy left (ttj) - set brc \u2524 ;# light (rtj) - set vllj \u2525 ;# heavy left (rtj) - set hlbj \u252c ;# (ttj) - } - default { - set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set tlc \u252c ;# [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc \u2524 ;# [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - } - } - down_right { - #6 - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - down_up { - #7 - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - left_right { - #8 - #from 2 - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - #from3 - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - } - #four way junction (cd::fwj) (punk::ansi::g0 n) (punk::char::charshort lvhz) (+) - } - "heavy" { - #unicode box drawing set - set hl [punk::char::charshort boxd_hhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_hv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_hdr] - set trc [punk::char::charshort boxd_hdl] - set blc [punk::char::charshort boxd_hur] - set brc [punk::char::charshort boxd_hul] - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'heavy' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - heavy { - set target$dir heavy - } - light - ascii - altg - arc { - set target$dir light - } - default { - set target$dir other - } - } - } - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - light { - set blc [punk::char::charshort boxd_dlruh] ;#\u2521 down light and right up heavy (ltj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) - set hlbj \u252F ;#down light (ttj) - } - heavy { - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set hlbj \u2533 ;# down heavy (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - light { - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) - set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) - set vllj \u2528 ;# left light (rtj) - } - heavy { - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set vllj \u252b ;#(rtj) - } - } - } - right { - #3 - switch -- $targetright { - light { - set trc [punk::char::charshort boxd_rlldh] ;#\u2531 Right Light and Left Down Heavy (ttj) - set brc [punk::char::charshort boxd_rlluh] ;#\u2539 Right Light and Left Up Heavy(btj) - set vlrj \u2520 ;#right light (ltj) - } - heavy { - set trc [punk::char::charshort boxd_hdhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set vlrj \u2523 ;# (ltj) - } - } - } - up { - #4 - switch -- $targetup { - light { - set tlc [punk::char::charshort boxd_ulrdh] ;#\u2522 Up Light and Right Down Heavy (ltj) - set trc [punk::char::charshort boxd_ulldh] ;#\u252a Up Light and Left Down Heavy (rtj) - set hltj \u2537 ;# up light (btj) - } - heavy { - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set hltj \u253b ;# (btj) - } - } - } - down_left { - #down_left is the main join type used for 'L' shaped cell border table building where we boxlimit to {vll hlb blc} - #5 - switch -- down-$targetdown-left-$targetleft { - down-light-left-heavy { - set blc [punk::char::charshort boxd_dluhzh] ;#down light and up horizontal heavy (fwj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) (at tlc down stays heavy) - set hlbj \u252F ;# down light (ttj) - set vllj \u252b ;#(rtj) - } - down-heavy-left-light { - set blc [punk::char::charshort boxd_llrvh] ;# left light and right Vertical Heavy (fwj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) (at brc left must stay heavy) - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) - set hlbj \u2533 ;# down heavy (ttj) - set vllj \u2528 ;# left light (rtj) - } - down-light-left-light { - set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) - set hlbj \u252F ;# down light (ttj) - set vllj \u2528 ;# left light (rtj) - } - down-heavy-left-heavy { - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set hlbj \u2533 ;#(ttj) - set vllj \u252b ;#(rtj) - } - down-other-left-heavy { - set blc \u253b ;#boxd_huhz Heavy Up and Horizontal (btj) - #leave brc default corner - set tlc \u2533 ;#hdhz Heavy Down and Horizontal (ttj) - - set vllj \u252b ;#(rtj) - } - down-other-left-light { - set blc \u253a ;#llruh Left Light and Right Up Heavy (btj) - #leave brc default corner - set tlc \u2532 ;#llrdh Left Light and Right Down Heavy (ttj) - - set vllj \u2528 ;# left light (rtj) - } - down-heavy-left-other { - set blc \u2523 ;#hvr Heavy Vertical and Right (ltj) - set brc \u252b ;#hvl Heavy Veritcal and Left (rtj) - #leave tlc default corner - - set hlbj \u2533 ;#(ttj) - } - down-light-left-other { - set blc \u2521 ;#dlruh Down Light and Right Up Heavy (ltj) - set brc \u2529 ;#dlluh Down Light and Left Up Heavy (rtj) - #leave tlc default corner - - set hlbj \u252F ;# down light (ttj) - } - } - } - down_right { - #6 - set blc [punk::char::charshort boxd_hvr] ;# (ltj) (blc right&up stay heavy) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) (tlc down&left stay heavy) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) (brc left&up heavy) - } - down_up { - #7 - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - } - left_right { - #8 - #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - } - } - } - "double" { - #unicode box drawing set - set hl [punk::char::charshort boxd_dhz] ;# double horizontal \U2550 - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551 - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554 - set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557 - set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A - set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - # \u256c (fwj) - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'double' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - double { - set target$dir double - } - light { - set target$dir light - } - default { - set target$dir other - } - } - } - - #unicode provides no joining for double to anything else - #better to leave a gap by using default double corners if join target is not empty or double - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - double { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - set hlbj \u2566 ;# (ttj) - } - light { - set hlbj \u2564 ;# down light (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - double { - set tlc \u2566 ;# (ttj) - set blc \u2569 ;# (btj) - set vllj \u2563 ;# (rtj) - } - light { - set vllj \u2562 ;# light left (rtj) - } - } - } - right { - #3 - switch -- $targetright { - double { - set trc \u2566 ;# (ttj) - set brc \u2569 ;# (btj) - } - light { - set vlrj \u255F ;# light right (ltj) - } - } - } - up { - #4 - switch -- $targetup { - double { - set tlc \u2560 ;# (ltj) - set trc \u2563 ;# (rtj) - set hltj \u2569 ;# (btj) - } - light { - set hltj \u2567 ;#up light (btj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - double-double { - set blc \u256c ;# (fwj) - set brc \u2563 ;# (rtj) - set tlc \u2566 ;# (ttj) - set hlbj \u2566 ;# (ttj) - } - double-light { - #no corner joins treat corners like 'other' - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - - set hlbj \u2566 ;# (ttj) - set vllj \u2562 ;# light left (rtj) - - } - double-other { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - #leave tlc as ordinary double corner - } - light-double { - - set vllj \u2563 ;# (rtj) - set hlbj \u2564 ;# light down (ttj) - - } - light-light { - - set vllj \u2562 ;# light left (rtj) - set hlbj \u2564 ;# light down (ttj) - } - other-light { - set vllj \u2562 ;# light left (rtj) - } - other-double { - set blc \u2569 ;# (btj) - #leave brc as ordinary double corner - set tlc \u2566 ;# (ttj) - } - } - } - down_right { - #6 - switch -- $targetdown-$targetright { - double-double { - set blc \u2560 ;# (ltj) - set trc \u2566 ;# (ttj) - set brc \u256c ;# (fwj) - set hlbj \u2566 ;# (ttj) - } - double-other { - set blc \u2560 ;# (ltj) - #leave trc default - set brc \u2563 ;# (rtj) - } - other-double { - #leave blc default - set trc \u2566 ;# (ttj) - set brc \u2569 ;#(btj) - } - } - } - down_up { - #7 - switch -- $targetdown-$targetup { - double-double { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - set tlc \u2560 ;# (ltj) - set trc \u2563 ;# (rtj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - } - } - left_right { - #8 - - #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set hltj \u2569 ;# (btj) - set vllj \u2563 ;# (rtj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set hltj \u2569 ;# (btj) - set vlrj \u2560 ;# (ltj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set hlbj \u2566 ;# (ttj) - set vlrj \u2560 ;# (ltj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set hltj \u2569 ;# (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - } - - } - "arc" { - #unicode box drawing set - - - set hl [punk::char::charshort boxd_lhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_lv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D - set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E - set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 - set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'arc' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - arc { - set target$dir self - } - default { - set target$dir other - } - } - } - - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - self { - set blc \u251c ;# *light (ltj) - #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left - #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable - #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal - - #set brc \u2524 ;# *light(rtj) - #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) - } - } - } - left { - #2 - switch -- $targetleft { - self { - set tlc \u252c ;# *light(ttj) - need a low positioned curved y shape - nothing apparent - #set blc \u2144 ;# (btj) - upside down y - positioning too low for arc - set blc \u2534 ;# *light (btj) - } - } - } - right { - #3 - switch -- $targetright { - self { - set trc \u252c ;# *light (ttj) - #set brc \u2144 ;# (btj) - set brc \u2534 ;# *light (btj) - } - } - } - up { - #4 - switch -- $targetup { - self { - set tlc \u251c ;# *light (ltj) - set trc \u2524 ;# *light(rtj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - self-self { - #set blc \u27e1 ;# white concave-sided diamond - positioned too far right - #set blc \u27e3 ;# concave sided diamond with rightwards tick - positioned too low, too right - big gaps - set brc \u2524 ;# *light (rtj) - set tlc \u252c ;# *light (ttj) - } - self-other { - #set blc \u2560 ;# (ltj) - #set brc \u2563 ;# (rtj) - #leave tlc as ordinary double corner - } - other-self { - #set blc \u2569 ;# (btj) - #leave brc as ordinary double corner - #set tlc \u2566 ;# (ttj) - } - } - } - } - } - block1 { - #box drawing as far as we can go without extra blocks from legacy computing unicode block - which is unfortunately not commonly supported - set hlt \u2581 ;# lower one eighth block - set hlb \u2594 ;# upper one eighth block - set vll \u258f ;# left one eighth block - set vlr \u2595 ;# right one eighth block - set tlc \u2581 ;# lower one eighth block - set trc \u2581 ;# lower one eighth block - set blc \u2594 ;# upper one eighth block - set brc \u2594 ;# upper one eight block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - } - block2 { - #the resultant table will have text appear towards top of each box - #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps - set hlt \u2594 ;# upper one eighth block - set hlb \u2581 ;# lower one eighth block - set vlr \u2595 ;# right one eighth block - set vll \u258f ;# left one eighth block - - set tlc \U1fb7d ;#legacy block - set trc \U1fb7e ;#legacy block - - set blc \U1fb7c ;#legacy block - set brc \U1fb7f ;#legacy block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - } - block { - set hlt \u2580 ;#upper half - set hlb \u2584 ;#lower half - set vll \u258c ;#left half - set vlr \u2590 ;#right half - - set tlc \u259b ;#upper left corner half - set trc \u259c - set blc \u2599 - set brc \u259f - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - } - default { - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing - if {[llength $f] % 2 != 0} { - #todo - retrieve usage from punk::args - error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $textblock::frametypes and does not appear to be a dictionary for a custom frametype" - } - #unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults - dict for {k v} $f { - switch -- $k { - hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} - default { - error "textblock::frametype '$f' has unknown element '$k'" - } - } - } - #verified keys - safe to extract as vars - set custom_frame [tcl::dict::merge $default_custom $f] - tcl::dict::with custom_frame {} ;#extract keys as vars - #longer j vars must be after their more specific counterparts in the list being processed by foreach - foreach t {hlt hlb vll vlr hltj hlbj vllj vlrj} { - if {[tcl::dict::exists $custom_frame $t]} { - set $t [tcl::dict::get $custom_frame $t] - } else { - #set more explicit type to it's more general counterpart if it's missing - #e.g hlt -> hl - #e.g hltj -> hlt - set $t [set [string range $t 0 end-1]] - } - } - #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set - #horizontal and vertical bar joins - key/variable ends with 'j' - } - } - if {$boxonly} { - set result [tcl::dict::create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - ] - tcl::dict::set framedef_cache $cache_key $result - return $result - } else { - set result [tcl::dict::create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - hltj $hltj\ - hlbj $hlbj\ - vllj $vllj\ - vlrj $vlrj\ - ] - tcl::dict::set framedef_cache $cache_key $result - return $result - } - } - - variable frame_cache - set frame_cache [tcl::dict::create] - proc frame_cache {args} { - set argd [punk::args::get_dict { - -action -default "" -choices {clear} -help "Clear the textblock::frame_cache dictionary" - -pretty -default 1 -help "Use 'pdict textblock::frame_cache */*' for prettier output" - *values -min 0 -max 0 - } $args] - set action [dict get $argd opts -action] - - if {$action ni [list clear ""]} { - error "frame_cache action '$action' not understood. Valid actions: clear" - } - variable frame_cache - if {[dict get $argd opts -pretty]} { - set out [pdict -chan none frame_cache */*] - } else { - set out "" - if {[catch { - set termwidth [tcl::dict::get [punk::console::get_size] columns] - }]} { - set termwidth 80 - } - - tcl::dict::for {k v} $frame_cache { - lassign $v _f frame _used used - set fwidth [textblock::widthtopline $frame] - #review - are cached frames uniform width lines? - #set fwidth [textblock::width $frame] - set frameinfo "$k used:$used " - set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] - if {$allinone_width >= $termwidth} { - #split across 2 lines - append out "$frameinfo\n" - append out $frame \n - } else { - append out [textblock::join -- $frameinfo $frame]\n - } - append out \n ;# frames used to build tables often have joins - keep a line in between for clarity - } - } - if {$action eq "clear"} { - set frame_cache [tcl::dict::create] - append out \nCLEARED - } - return $out - } - - - #options before content argument - which is allowed to be absent - #frame performance (noticeable with complex tables even of modest size) is improved significantly by frame_cache - but is still (2024) a fairly expensive operation. - # - #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) - # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? - #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand - #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it - # - but we would need to maintain support for the rendered-string based operations too. - proc frame {args} { - variable frametypes - - #counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var - set opts [tcl::dict::create\ - -etabs 0\ - -type light\ - -boxlimits [list hl vl tlc blc trc brc]\ - -boxmap {}\ - -joins [list]\ - -title ""\ - -subtitle ""\ - -width ""\ - -height ""\ - -ansiborder ""\ - -ansibase ""\ - -blockalign "centre"\ - -textalign "left"\ - -ellipsis 1\ - -usecache 1\ - -buildcache 1\ - ] - - set expect_optval 0 - set argposn 0 - set pmax [expr {[llength $args]-1}] - set has_contents 0 ;#differentiate between empty string and no content supplied - set contents "" - set arglist [list] - foreach a $args { - if {!$expect_optval} { - if {$argposn < $pmax} { - if {[tcl::string::match -* $a]} { - set expect_optval 1 - lappend arglist $a - } else { - error "textblock::frame expects -option pairs" - } - } else { - set has_contents 1 - set contents $a - } - } else { - lappend arglist $a - set expect_optval 0 - } - incr argposn - } - - #set contents [lindex $args end] - #set arglist [lrange $args 0 end-1] - if {[llength $arglist] % 2 != 0} { - error "Usage frame ?-type unicode|altg|ascii|? ?-title ? ?-subtitle ? ?-width ? ?-ansiborder ? ?-boxlimits hl|hlt|hlb|vl|vll|vlr|tlc|blc|brc? ?-joins left|right|up|down? " - } - #todo args -justify left|centre|right (center) - - #todo -blockalignbias -textalignbias? - #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache - foreach {k v} $arglist { - switch -- $k { - -etabs - -type - -boxlimits - -boxmap - -joins - -title - -subtitle - -width - -height - -ansiborder - -ansibase - -blockalign - -textalign - -ellipsis - -usecache - -buildcache { - tcl::dict::set opts $k $v - } - default { - error "frame option '$k' not understood. Valid options are [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- - set opt_etabs [tcl::dict::get $opts -etabs] - set opt_type [tcl::dict::get $opts -type] - set opt_boxlimits [tcl::dict::get $opts -boxlimits] - set opt_joins [tcl::dict::get $opts -joins] - set opt_boxmap [tcl::dict::get $opts -boxmap] - set opt_usecache [tcl::dict::get $opts -usecache] - set opt_buildcache [tcl::dict::get $opts -buildcache] - set usecache $opt_usecache ;#may need to override - set buildcache $opt_buildcache - set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - - set known_frametypes $frametypes ;# light, heavey etc as defined in textblock::frametypes variable - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - - lassign [textblock::frametype $opt_type] _cat category _type ftype - if {$category eq "custom"} { - set custom_frame $ftype - set frameset "custom" - set framedef $custom_frame - } else { - #category = predefined - set frameset $ftype ;# light,heavy etc - set framedef $ftype - } - - set is_boxlimits_ok 1 - set exact_boxlimits [list] - foreach v $opt_boxlimits { - switch -- $v { - hl { - lappend exact_boxlimits hlt hlb - } - vl { - lappend exact_boxlimits vll vlr - } - hlt - hlb - vll - vlr - tlc - trc - blc - brc { - lappend exact_boxlimits $v - } - default { - #k not in custom_keys - set is_boxlimits_ok 0 - break - } - } - } - if {!$is_boxlimits_ok} { - error "frame option -boxlimits '$opt_boxlimits' must contain only values from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - set exact_boxlimits [lsort -unique $exact_boxlimits] - - set is_joins_ok 1 - foreach v $opt_joins { - lassign [split $v -] direction target - switch -- $direction { - left - right - up - down {} - default { - set is_joins_ok 0 - break - } - } - switch -- $target { - "" - light - heavy - ascii - altg - arc - double - custom - block - block1 - block2 {} - default { - set is_joins_ok 0 - break - } - } - } - if {!$is_joins_ok} { - error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" - } - set is_boxmap_ok 1 - #safe jumptable test - #dict for {boxelement subst} $opt_boxmap {} - tcl::dict::for {boxelement subst} $opt_boxmap { - switch -- $boxelement { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - default { - set is_boxmap_ok 0 - break - } - } - } - if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - - #sorted order down left right up - #1 x choose 4 - #4 x choose 3 - #6 x choose 2 - #4 x choose 1 - #15 combos - - set join_directions [list] - #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode - #e.g down-light, up-heavy - set join_targets [tcl::dict::create left "" down "" right "" up ""] - foreach jt $opt_joins { - lassign [split $jt -] direction target - if {$target ne ""} { - tcl::dict::set join_targets $direction $target - } - lappend join_directions $direction - } - set join_directions [lsort -unique $join_directions] - set do_joins [::join $join_directions _] - - - # -- --- --- --- --- --- - set opt_title [tcl::dict::get $opts -title] - set opt_subtitle [tcl::dict::get $opts -subtitle] - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - # -- --- --- --- --- --- - set opt_blockalign [tcl::dict::get $opts -blockalign] - switch -- $opt_blockalign { - left - right - centre - center {} - default { - error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign" - } - } - #these are all valid commands for overtype:: - # -- --- --- --- --- --- - set opt_textalign [tcl::dict::get $opts -textalign] - switch -- $opt_textalign { - left - right - centre - center {} - default { - error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" - } - } - # -- --- --- --- --- --- - - set opt_ansiborder [tcl::dict::get $opts -ansiborder] - set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - # -- --- --- --- --- --- - - if {$has_contents} { - if {[tcl::string::last \t $contents] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - if {$opt_etabs} { - set contents [textutil::tabify::untabify2 $contents $tw] - } - } - set contents [tcl::string::map [list \r\n \n] $contents] - set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) - set actual_contentheight [textblock::height $contents] - } else { - set actual_contentwidth 0 - set actual_contentheight 0 - } - - if {$opt_title ne ""} { - set titlewidth [punk::ansi::printing_length $opt_title] - set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}] - } else { - set titlewith 0 - set content_or_title_width $actual_contentwidth - } - - if {$opt_width eq ""} { - set frame_inner_width $content_or_title_width - } else { - set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default - } - - if {$opt_height eq ""} { - set frame_inner_height $actual_contentheight - } else { - set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default - } - if {$frame_inner_height == 0 && $frame_inner_width == 0} { - set has_contents 0 - } - #todo - render it with vertical overflow so we can process ansi moves? - #set linecount [textblock::height $contents] - set linecount $frame_inner_height - - # -- --- --- --- --- --- --- --- --- - variable frame_cache - #review - custom frame affects frame_inner_width - exclude from caching? - #set cache_key [concat $arglist $frame_inner_width $frame_inner_height] - set hashables [concat $arglist $frame_inner_width $frame_inner_height] - package require md5 - #set hash $hashables - set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review - set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth" - #should be in a unicode private range different to that used in table construction - #e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts - #also supplementary private use blocks - #however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult) - #U+F0000 -> U+FFFD - #U+100000 -> U+10FFFD - #FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy) - #should be something someone is unlikely to use as part of a custom frame character. - #ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better) - #As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string - #terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like. - #e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never" - #review - we could consider wasting a few cycles to check for a conflict and use a different FSUB - set FSUB \uF2DD - - - #this occurs commonly in table building with colspans - review - if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { - set usecache 0 - #set buildcache 0 ;#comment out for debug/analysis so we can see - #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" - set cache_key [a+ Web-red web-white]$cache_key[a] - } - if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { - #colourise cache_key to warn - if {$actual_contentwidth == 0} { - #we can still substitute with right length - set cache_key [a+ Web-steelblue web-black]$cache_key[a] - } else { - #actual_contentwidth is narrower than frame - check template's patternwidth - if {[tcl::dict::exists $frame_cache $cache_key]} { - set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] - } else { - set cache_patternwidth $actual_contentwidth - } - if {$actual_contentwidth < $cache_patternwidth} { - set usecache 0 - set cache_key [a+ Web-orange web-black]$cache_key[a] - } elseif {$actual_contentwidth == $cache_patternwidth} { - #set usecache 1 - } else { - #actual_contentwidth > pattern - set usecache 0 - set cache_key [a+ Web-red web-black]$cache_key[a] - } - } - } - - #JMN debug - #set usecache 0 - - set is_cached 0 - if {$usecache && [tcl::dict::exists $frame_cache $cache_key]} { - set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] - set template [tcl::dict::get $frame_cache $cache_key frame] - set used [tcl::dict::get $frame_cache $cache_key used] - tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record - set is_cached 1 - - } - - # -- --- --- --- --- --- --- --- --- - if {!$is_cached} { - set rst [a] - #set column [tcl::string::repeat " " $frame_inner_width] ;#default - may need to override for custom frame - set underlayline [tcl::string::repeat " " $frame_inner_width] - set underlay [::join [lrepeat $linecount $underlayline] \n] - - - set vll_width 1 ;#default for all except custom (printing width) - set vlr_width 1 - - set framedef [textblock::framedef -joins $opt_joins $framedef] - tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars - - #puts "---> $opt_boxmap" - #review - we handle double-wide in custom frames - what about for boxmaps? - tcl::dict::for {boxelement sub} $opt_boxmap { - if {$boxelement eq "vl"} { - set vll $sub - set vlr $sub - set hl $sub - } elseif {$boxelement eq "hl"} { - set hlt $sub - set hlb $sub - set hl $sub - } else { - set $boxelement $sub - } - } - - switch -- $frameset { - custom { - #REVIEW - textblock::table assumes that at least the vl elements are 1-wide - #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though - #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely - set vll_width [punk::ansi::printing_length $vll] - set hlb_width [punk::ansi::printing_length $hlb] - set hlt_width [punk::ansi::printing_length $hlt] - - set vlr_width [punk::ansi::printing_length $vlr] - - set tlc_width [punk::ansi::printing_length $tlc] - set trc_width [punk::ansi::printing_length $trc] - set blc_width [punk::ansi::printing_length $blc] - set brc_width [punk::ansi::printing_length $brc] - - - set framewidth [expr {$frame_inner_width + 2}] ;#reverse default assumption - if {$opt_width eq ""} { - #width wasn't specified - so user is expecting frame to adapt to title/contents - #content shouldn't truncate because of extra wide frame - #review - punk::console::get_size ? wrapping? quite hard to support with colspans - set frame_inner_width $content_or_title_width - set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width - set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] - } else { - set frame_inner_width [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated - set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}] - set bbarwidth [expr {$opt_width - $blc_width - $brc_width}] - } - #set column [tcl::string::repeat " " $frame_inner_width] - set underlayline [tcl::string::repeat " " $frame_inner_width] - set underlay [::join [lrepeat $linecount $underlayline] \n] - #cache? - - if {$hlt_width == 1} { - set tbar [tcl::string::repeat $hlt $tbarwidth] - } else { - #possibly mixed width chars that make up hlt - tcl::string::range won't get width right - set blank [tcl::string::repeat " " $tbarwidth] - if {$hlt_width > 0} { - set count [expr {($tbarwidth / $hlt_width) + 1}] - } else { - set count 0 - } - set tbar [tcl::string::repeat $hlt $count] - #set tbar [tcl::string::range $tbar 0 $tbarwidth-1] - set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character - } - if {$hlb_width == 1} { - set bbar [tcl::string::repeat $hlb $bbarwidth] - } else { - set blank [tcl::string::repeat " " $bbarwidth] - if {$hlb_width > 0} { - set count [expr {($bbarwidth / $hlb_width) + 1}] - } else { - set count 0 - } - set bbar [tcl::string::repeat $hlb $count] - #set bbar [tcl::string::range $bbar 0 $bbarwidth-1] - set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] - } - } - altg { - set tbar [tcl::string::repeat $hlt $frame_inner_width] - set tbar [cd::groptim $tbar] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - set bbar [cd::groptim $bbar] - } - default { - set tbar [tcl::string::repeat $hlt $frame_inner_width] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - - } - } - - set leftborder 0 - set rightborder 0 - set topborder 0 - set bottomborder 0 - # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - #puts "----->$exact_boxlimits" - foreach lim $exact_boxlimits { - switch -- $lim { - hlt { - set topborder 1 - } - hlb { - set bottomborder 1 - } - vll { - set leftborder 1 - } - vlr { - set rightborder 1 - } - tlc { - set topborder 1 - set leftborder 1 - } - trc { - set topborder 1 - set rightborder 1 - } - blc { - set bottomborder 1 - set leftborder 1 - } - brc { - set bottomborder 1 - set rightborder 1 - } - } - } - if {$opt_width ne "" && $opt_width < 2} { - set rightborder 0 - } - #keep lhs/rhs separate? can we do vertical text on sidebars? - set lhs [tcl::string::repeat $vll\n $linecount] - set lhs [tcl::string::range $lhs 0 end-1] - set rhs [tcl::string::repeat $vlr\n $linecount] - set rhs [tcl::string::range $rhs 0 end-1] - - - if {$opt_ansiborder ne ""} { - set tbar $opt_ansiborder$tbar$rst - set bbar $opt_ansiborder$bbar$rst - set tlc $opt_ansiborder$tlc$rst - set trc $opt_ansiborder$trc$rst - set blc $opt_ansiborder$blc$rst - set brc $opt_ansiborder$brc$rst - - set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out - set rhs $opt_ansiborder$rhs$rst - } - - #boxlimits used for partial borders in table generation - set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] - set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] - foreach lim $unspecified_limits { - switch -- $lim { - vll { - set blank_vll [tcl::string::repeat " " $vll_width] - set lhs [tcl::string::repeat $blank_vll\n $linecount] - set lhs [tcl::string::range $lhs 0 end-1] - } - vlr { - set blank_vlr [tcl::string::repeat " " $vlr_width] - set rhs [tcl::string::repeat $blank_vlr\n $linecount] - set rhs [tcl::string::range $rhs 0 end-1] - } - hlt { - set bar_width [punk::ansi::printing_length $tbar] - set tbar [tcl::string::repeat " " $bar_width] - } - tlc { - set tlc_width [punk::ansi::printing_length $tlc] - set tlc [tcl::string::repeat " " $tlc_width] - } - trc { - set trc_width [punk::ansi::printing_length $trc] - set trc [tcl::string::repeat " " $trc_width] - } - hlb { - set bar_width [punk::ansi::printing_length $bbar] - set bbar [tcl::string::repeat " " $bar_width] - } - blc { - set blc_width [punk::ansi::printing_length $blc] - set blc [tcl::string::repeat " " $blc_width] - } - brc { - set brc_width [punk::ansi::printing_length $brc] - set brc [tcl::string::repeat " " $brc_width] - } - } - } - - if {$opt_title ne ""} { - set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off - } else { - set topbar $tbar - } - if {$opt_subtitle ne ""} { - set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off - } else { - set bottombar $bbar - } - if {$opt_ansibase eq ""} { - set rstbase [a] - } else { - set rstbase [a]$opt_ansibase - } - - if {$opt_title ne ""} { - #title overrides -boxlimits for topborder - set topborder 1 - } - set fs "" - set fscached "" - set cache_patternwidth 0 - #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? - if {$topborder} { - if {$leftborder && $rightborder} { - append fs $tlc$topbar$trc - } else { - if {$leftborder} { - append fs $tlc$topbar - } elseif {$rightborder} { - append fs $topbar$trc - } else { - append fs $topbar - } - } - } - append fscached $fs - if {$has_contents || $opt_height > 2} { - #if {$topborder && $fs ne "xx"} { - # append fs \n - #} - if {$topborder} { - append fs \n - append fscached \n - } - switch -- $opt_textalign { - right {set pad "left"} - left {set pad "right"} - default {set pad $opt_textalign} - } - #set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1] - #set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents] - - set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth] - set cache_patternwidth $actual_contentwidth - set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] - set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] - #after overtype::block - our actual patternwidth may be less - set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] - - if {$leftborder && $rightborder} { - #set bodyparts [list $lhs $inner $rhs] - set cache_bodyparts [list $lhs $cache_inner $rhs] - } else { - if {$leftborder} { - #set bodyparts [list $lhs $inner] - set cache_bodyparts [list $lhs $cache_inner] - } elseif {$rightborder} { - #set bodyparts [list $inner $rhs] - set cache_bodyparts [list $cache_inner $rhs] - } else { - #set bodyparts [list $inner] - set cache_bodyparts [list $cache_inner] - } - } - #set body [textblock::join -- {*}$bodyparts] - set cache_body [textblock::join -- {*}$cache_bodyparts] - append fscached $cache_body - #append fs $body - } - - if {$opt_height eq "" || $opt_height > 1} { - if {$opt_subtitle ne ""} { - #subtitle overrides boxlimits for bottomborder - set bottomborder 1 - } - if {$bottomborder} { - if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { - #append fs \n - append fscached \n - } - if {$leftborder && $rightborder} { - #append fs $blc$bottombar$brc - append fscached $blc$bottombar$brc - } else { - if {$leftborder} { - #append fs $blc$bottombar - append fscached $blc$bottombar - } elseif {$rightborder} { - #append fs $bottombar$brc - append fscached $bottombar$brc - } else { - #append fs $bottombar - append fscached $bottombar - } - } - } - } - set template $fscached - ;#end !$is_cached - } - - #use the same mechanism to build the final frame - whether from cache or template - if {$actual_contentwidth == 0} { - set fs [tcl::string::map [list $FSUB " "] $template] - } else { - set resultlines [list] - set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] - set contentindex 0 - switch -- $opt_textalign { - left {set pad right} - right {set pad left} - default {set pad $opt_textalign} - } - - #review - if {[tcl::string::is integer -strict $opt_height] && $actual_contentheight < ($opt_height -2)} { - set diff [expr {($opt_height -2) - $actual_contentheight}] - append contents [::join [lrepeat $diff \n] ""] - } - - set paddedcontents [textblock::pad $contents -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) - set paddedwidth [textblock::widthtopline $paddedcontents] - - #review - horizontal truncation - if {$paddedwidth > $cache_patternwidth} { - set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] - } - #important to supply end of opts -- to textblock::join - particularly here with arbitrary data - set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays - - set tlines [split $template \n] - - #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. - #after textblock::join the reset will be a separate code ie should be exactly ESC[0m - set R [a] - set rlen [tcl::string::length $R] - set clines [split $contentblock \n] - - foreach tline $tlines { - if {[tcl::string::first $FSUB $tline] >= 0} { - set content_line [lindex $clines $contentindex] - if {[tcl::string::first $R $content_line] == 0} { - set content_line [tcl::string::range $content_line $rlen end] - } - #make sure to replay opt_ansibase to the right of the replacement - lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline] - incr contentindex - } else { - lappend resultlines $tline - } - } - set fs [::join $resultlines \n] - } - - - if {$is_cached} { - return $fs - } else { - if {$buildcache} { - tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] - } - return $fs - } - } - proc gcross {args} { - set argd [punk::args::get_dict { - -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block - Only cross sizes that divide the size of the overall block will be used. - e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. - Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) - If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. - " - *values -min 1 - size -default 1 -type integer - } $args] - set size [dict get $argd values size] - set opts [dict get $argd opts] - - if {$size == 0} { - return "" - } - - set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] - - #set fit_size [punk::lib::greatestOddFactor $size] - set fit_size $size - if {$opt_max_cross_size == 0} { - set max_cross_size $fit_size - } else { - #todo - only allow divisors - #set testsize [expr {min($fit_size,$opt_max_cross_size)}] - - set factors [punk::lib::factors $size] - #pick odd size in list that is smaller or equal to test_size - set max_cross_size [lindex $factors end] - set last_ok [lindex $factors 0] - for {set i 0} {$i < [llength $factors]} {incr i} { - set s [lindex $factors $i] - if {$s > $opt_max_cross_size} { - break - } - set last_ok $s - } - set max_cross_size $last_ok - } - set crosscount [expr {$size / $max_cross_size}] - - package require punk::char - set x [punk::char::charshort boxd_ldc] - set bs [punk::char::charshort boxd_ldgullr] - set fs [punk::char::charshort boxd_ldgurll] - - set onecross "" - set crossrows [list] - set armsize [expr {int(floor($max_cross_size /2))}] - set row [lrepeat $max_cross_size " "] - #toparm - for {set i 0} {$i < $armsize} {incr i} { - set r $row - lset r $i $bs - lset r end-$i $fs - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - - if {$max_cross_size % 2 != 0} { - #only put centre cross in for odd sized crosses - set r $row - lset r $armsize $x - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - - for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} { - set r $row - lset r $i $fs - lset r end-$i $bs - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - #set onecross [tcl::string::trimright $onecross \n] - set onecross [::join $crossrows \n] - - #fastest to do row first then columns - because textblock::join must do line by line - - if {$crosscount > 1} { - package require textblock - set row [textblock::join -- {*}[lrepeat $crosscount $onecross]] - set rows [lrepeat $crosscount $row] - set out [::join $rows \n] - } else { - set out $onecross - } - - return $out - } - - #Test we can join two coloured blocks - proc test_colour {} { - set b1 [a red]1\n2\n3[a] - set b2 [a green]a\nb\nc[a] - set result [textblock::join -- $b1 $b2] - puts $result - #return [list $b1 $b2 $result] - return [ansistring VIEW $result] - } - tcl::namespace::import ::punk::ansi::ansistrip -} - - -tcl::namespace::eval ::textblock::piper { - tcl::namespace::export * - proc join {rhs pipelinedata} { - tailcall ::textblock::join -- $pipelinedata $rhs - } -} -interp alias {} piper_blockjoin {} ::textblock::piper::join - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide textblock [tcl::namespace::eval textblock { - variable version - set version 0.1.1 -}] -return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textblock-0.1.3.tm similarity index 93% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm rename to src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textblock-0.1.3.tm index a3d5b967..c102ca29 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application textblock 0.1.2 +# Application textblock 0.1.3 # Meta platform tcl # Meta license # @@ Meta End @@ -16,10 +16,10 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_textblock 0 0.1.2] +#[manpage_begin punkshell_module_textblock 0 0.1.3] #[copyright "2024"] #[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] +#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] #[require textblock] #[keywords module ansi text layout colour table frame console terminal] #[description] @@ -29,7 +29,7 @@ #*** !doctools #[section Overview] -#[para] overview of textblock +#[para] overview of textblock #[subsection Concepts] #[para] @@ -39,7 +39,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by textblock +#[para] packages used by textblock #[list_begin itemized] #*** !doctools @@ -62,14 +62,16 @@ catch {package require patternpunk} package require overtype #safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. -if {[catch { - package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? -} errM]} { - #catch this too in case stderr not available - catch { - puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM" - } -} +#2025 - required term::ansi features for altg now built in to textblock +#the deeper paths issue is still a potential issue for some packages - review +#if {[catch { +# package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? +#} errM]} { +# #catch this too in case stderr not available +# catch { +# puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM" +# } +#} package require textutil @@ -88,7 +90,7 @@ package require textutil tcl::namespace::eval textblock { #review - what about ansi off in punk::console? tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ - tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock + tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock #NOTE sha1, although computationally more intensive, tends to be faster than md5 on modern cpus #(more likely to be optimised for modern cpu features?) @@ -96,42 +98,61 @@ tcl::namespace::eval textblock { variable use_hash ;#framecache set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display - #if {![catch {package require sha1}]} { - # set use_hash sha1 - #} elseif {![catch {package require md5}]} { - # set use_hash md5 - #} else { - # set use_hash none - #} - proc use_hash {args} { - set choices [list none] - set unavailable [list] - set pkgs [package names] - if {"md5" in $pkgs} { - lappend choices md5 - } else { - lappend unavailable md5 + namespace eval argdoc { + proc hash_algorithm_choices_and_help {} { + set choices [list none] + set unavailable [list] + set unloaded [dict create] + set algorithm_packages {md5 sha1 sha256} + foreach p $algorithm_packages { + if {[package provide $p] eq ""} { + dict set unloaded $p "" + } + } + if {[dict size $unloaded]} { + set allpkgs [package names] ;#only retrieve once + foreach p $algorithm_packages { + if {[dict exists $unloaded $p]} { + #not loaded - but check if available + if {$p in $allpkgs} { + lappend choices $p + } else { + lappend unavailable $p + } + } else { + lappend choices $p + } + } + } else { + lappend choices {*}$algorithm_packages + set unavailable "" + } + + set choicemsg "" + if {[llength $unavailable]} { + set choicemsg " (unavailable packages: $unavailable)" + } + #return $choices + return " -choices \{$choices\} -help {algorithm choice $choicemsg} " } - if {"sha1" in $pkgs} { - lappend choices sha1 - } else { - lappend unavailable sha1 - } - set choicemsg "" - if {[llength $unavailable]} { - set choicemsg " (unavailable packages: $unavailable)" - } - set argd [punk::args::get_dict [tstr -return string { - @id -id ::textblock::use_hash - @cmd -name "textblock::use_hash" -help\ - "Hashing algorithm to use for framecache lookup. - 'none' may be slightly faster but less compact - when viewing textblock::framecache" - @values -min 0 -max 1 - hash_algorithm -choices {${$choices}} -optional 1 -help\ - "algorithm choice ${$choicemsg}" - }] $args] + } + + # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\ + # "algorithm choice" + + punk::args::define { + @dynamic + @id -id ::textblock::use_hash + @cmd -name "textblock::use_hash" -help\ + "Hashing algorithm to use for framecache lookup. + 'none' may be slightly faster but less compact + when viewing textblock::framecache" + @values -min 0 -max 1 + hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} + } + proc use_hash {args} { + set argd [punk::args::get_by_id ::textblock::use_hash $args] variable use_hash if {![dict exists $argd received hash_algorithm]} { return $use_hash @@ -198,7 +219,7 @@ tcl::namespace::eval textblock { #ie only vll,blc,hlb used for cells except top row and right column #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) #right cells use 'U' shape (vll,blc,hlb,brc,vlr) - #e.g for 4x4 + #e.g for 4x4 # C C C O # L L L U # L L L U @@ -208,7 +229,7 @@ tcl::namespace::eval textblock { set L [list vll blc hlb] set U [list vll blc hlb brc vlr] set tops [list trc hlt tlc] - set lefts [list tlc vll blc] + set lefts [list tlc vll blc] set bottoms [list blc hlb brc] set rights [list trc brc vlr] @@ -470,8 +491,8 @@ tcl::namespace::eval textblock { set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] set seps $requested_seps - set seps_h $requested_seps_h - set seps_v $requested_seps_v + set seps_h $requested_seps_h + set seps_v $requested_seps_v if {$requested_seps eq ""} { if {$requested_seps_h eq ""} { set seps_h 1 @@ -481,10 +502,10 @@ tcl::namespace::eval textblock { } } else { if {$requested_seps_h eq ""} { - set seps_h $seps + set seps_h $seps } if {$requested_seps_v eq ""} { - set seps_v $seps + set seps_v $seps } } return [tcl::dict::create horizontal $seps_h vertical $seps_v] @@ -494,8 +515,8 @@ tcl::namespace::eval textblock { set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] set ft $requested_ft - set ft_header $requested_ft_header - set ft_body $requested_ft_body + set ft_header $requested_ft_header + set ft_body $requested_ft_body switch -- $requested_ft { light { if {$requested_ft_header eq ""} { @@ -523,10 +544,10 @@ tcl::namespace::eval textblock { } default { if {$requested_ft_header eq ""} { - set ft_header $requested_ft + set ft_header $requested_ft } if {$requested_ft_body eq ""} { - set ft_body $requested_ft + set ft_body $requested_ft } } } @@ -600,7 +621,7 @@ tcl::namespace::eval textblock { if {![llength $args]} { return $o_opts_table - } + } if {[llength $args] == 1} { if {[lindex $args 0] in [list %topt_keys%]} { #query single option @@ -613,7 +634,7 @@ tcl::namespace::eval textblock { tcl::dict::set infodict debug [ansistring VIEW $val] } -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { - tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] + tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] } } tcl::dict::set returndict info $infodict @@ -642,11 +663,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set ansi_codes [list] ; + set ansi_codes [list] foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend ansi_codes $code @@ -663,7 +684,7 @@ tcl::namespace::eval textblock { -framemap_body - -framemap_header { #upvar ::textblock::class::opts_table_defaults tdefaults #set default_bmap [tcl::dict::get $tdefaults -framemap_body] - #todo - check keys and map + #todo - check keys and map if {[llength $v] == 1} { if {$v eq "default"} { upvar ::textblock::class::opts_table_defaults tdefaults @@ -679,7 +700,7 @@ tcl::namespace::eval textblock { switch -- $subk { topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} default { - error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" + error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" } } #safe jumptable test @@ -731,14 +752,14 @@ tcl::namespace::eval textblock { } -show_hseps { if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } lappend checked_opts $k $v #these don't affect column width calculations } -show_edge { if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } lappend checked_opts $k $v #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play @@ -747,7 +768,7 @@ tcl::namespace::eval textblock { -show_vseps { #we allow empty string - so don't use -strict boolean check if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } #affects width calculations set o_calculated_column_widths [list] @@ -786,7 +807,7 @@ tcl::namespace::eval textblock { if {[my width] < [expr {$twidth+2}]} { set o_calculated_column_widths [list] tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] - } + } tcl::dict::set o_opts_table -title $v } default { @@ -819,7 +840,7 @@ tcl::namespace::eval textblock { } } #ansireset exception - tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] + tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] return $o_opts_table } @@ -837,7 +858,7 @@ tcl::namespace::eval textblock { for {set c 0} {$c < $matrix_colcount} {incr c} { my add_column -headers "" } - } + } set table_colcount [my column_count] if {$table_colcount != $matrix_colcount} { error "textblock::table::printmatrix column count of table doesn't match column count of matrix" @@ -853,7 +874,7 @@ tcl::namespace::eval textblock { method as_matrix {{cmd ""}} { #*** !doctools #[call class::table [method as_matrix] [arg ?cmd?]] - #[para] return a struct::matrix command representing the data portion of the table. + #[para] return a struct::matrix command representing the data portion of the table. if {$cmd eq ""} { set m [struct::matrix] @@ -862,8 +883,8 @@ tcl::namespace::eval textblock { } $m add columns [tcl::dict::size $o_columndata] $m add rows [tcl::dict::size $o_rowdefs] - tcl::dict::for {k v} $o_columndata { - $m set column $k $v + tcl::dict::for {k v} $o_columndata { + $m set column $k $v } return $m } @@ -886,17 +907,17 @@ tcl::namespace::eval textblock { } } } - set colcount [tcl::dict::size $o_columndefs] + set colcount [tcl::dict::size $o_columndefs] tcl::dict::set o_columndata $colcount [list] - #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists - tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists + #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists + tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] set prev_calculated_column_widths $o_calculated_column_widths - if {[catch { + if {[catch { my configure_column $colcount {*}$opts } errMsg]} { #configure failed - ensure o_columndata and o_columndefs entries are removed @@ -905,7 +926,7 @@ tcl::namespace::eval textblock { tcl::dict::unset o_columnstates $colcount #undo cache invalidation set o_calculated_column_widths $prev_calculated_column_widths - error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" + error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" } #any add_column that succeeds should invalidate the calculated column widths set o_calculated_column_widths [list] @@ -924,7 +945,7 @@ tcl::namespace::eval textblock { method column_count {} { #*** !doctools #[call class::table [method column_count]] - #[para] return the number of columns + #[para] return the number of columns return [tcl::dict::size $o_columndefs] } method configure_column {index_expression args} { @@ -935,7 +956,7 @@ tcl::namespace::eval textblock { set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" - } + } if {![llength $args]} { return [tcl::dict::get $o_columndefs $cidx] } else { @@ -970,7 +991,7 @@ tcl::namespace::eval textblock { } set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state - set hstates $o_headerstates ;#operate on a copy + set hstates $o_headerstates ;#operate on a copy set colstate [tcl::dict::get $o_columnstates $cidx] set args_got_headers 0 set args_got_header_colspans 0 @@ -979,7 +1000,7 @@ tcl::namespace::eval textblock { -headers { set args_got_headers 1 set i 0 - set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. + set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. foreach hdr $v { set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns #set this_header_height [textblock::height $hdr] @@ -1031,7 +1052,7 @@ tcl::namespace::eval textblock { # } #} else { set header_spans [tcl::dict::get $cspans $h] - set remaining [lindex $header_spans 0] + set remaining [lindex $header_spans 0] if {$remaining ne "any"} { incr remaining -1 } @@ -1088,11 +1109,11 @@ tcl::namespace::eval textblock { } -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set col_ansibase_items [list] ; + set col_ansibase_items [list] foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend col_ansibase_items $code @@ -1125,13 +1146,13 @@ tcl::namespace::eval textblock { } #args checked - ok to update headerstates, headerdefs and columndefs and columnstates tcl::dict::set o_columndefs $cidx $checked_opts - set o_headerstates $hstates + set o_headerstates $hstates dict for {hidx hstate} $hstates { #configure_header if {![dict exists $o_headerdefs $hidx]} { #remove calculated members -values -colspans set hdefaults [dict remove $o_opts_header_defaults -values -colspans] - dict set o_headerdefs $hidx $hdefaults + dict set o_headerdefs $hidx $hdefaults } } @@ -1162,7 +1183,7 @@ tcl::namespace::eval textblock { method header_count {} { #*** !doctools #[call class::table [method header_count]] - #[para] return the number of header rows + #[para] return the number of header rows return [tcl::dict::size $o_headerstates] } method header_count_calc {} { @@ -1211,7 +1232,7 @@ tcl::namespace::eval textblock { method header_colspans {} { #*** !doctools #[call class::table [method header_colspans]] - #[para] Show the colspans configured for all headers + #[para] Show the colspans configured for all headers #set num_headers [my header_count_calc] set num_headers [my header_count] @@ -1221,9 +1242,9 @@ tcl::namespace::eval textblock { set colspans_for_column [tcl::dict::get $cdef -header_colspans] for {set h 0} {$h < $num_headers} {incr h} { set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] - set defined_span [lindex $colspans_for_column $h] + set defined_span [lindex $colspans_for_column $h] set i 0 - set spanremaining [lindex $headerspans 0] + set spanremaining [lindex $headerspans 0] if {$spanremaining ne "any"} { if {$spanremaining eq ""} { set spanremaining 1 @@ -1235,7 +1256,7 @@ tcl::namespace::eval textblock { set spanremaining "any" } elseif {$s == 0} { if {$spanremaining ne "any"} { - incr spanremaining -1 + incr spanremaining -1 } } else { set spanremaining [expr {$s - 1}] @@ -1252,7 +1273,7 @@ tcl::namespace::eval textblock { } else { lappend headerspans $defined_span } - tcl::dict::set colspans_by_header $h $headerspans + tcl::dict::set colspans_by_header $h $headerspans } } return $colspans_by_header @@ -1280,10 +1301,10 @@ tcl::namespace::eval textblock { } incr spanlen } - #overwrite the 'any' with it's actual span + #overwrite the 'any' with it's actual span set modified_spans [dict get $hcolspans $h] lset modified_spans $c $spanlen - dict set hcolspans $h $modified_spans + dict set hcolspans $h $modified_spans } incr c } @@ -1294,7 +1315,7 @@ tcl::namespace::eval textblock { method configure_header {index_expression args} { #*** !doctools #[call class::table [method configure_header]] - #[para] - configure header row-wise + #[para] - configure header row-wise #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis @@ -1310,7 +1331,7 @@ tcl::namespace::eval textblock { } if {![llength $args]} { - set colspans_by_header [my header_colspans] + set colspans_by_header [my header_colspans] set result [tcl::dict::create] tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] set header_row_items [list] @@ -1318,9 +1339,9 @@ tcl::namespace::eval textblock { set colheaders [tcl::dict::get $cdef -headers] set relevant_header [lindex $colheaders $hidx] #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. } - tcl::dict::set result -values $header_row_items + tcl::dict::set result -values $header_row_items #review - ensure always a headerdef record for each header? if {[tcl::dict::exists $o_headerdefs $hidx]} { @@ -1338,7 +1359,7 @@ tcl::namespace::eval textblock { #set val [tcl::dict::get $o_rowdefs $ridx $k] set infodict [tcl::dict::create] - #todo + #todo # -blockalignments and -textalignments lists # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} #if there is a value it overrides alignments specified on the column @@ -1349,14 +1370,14 @@ tcl::namespace::eval textblock { set colheaders [tcl::dict::get $cdef -headers] set relevant_header [lindex $colheaders $hidx] #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. } - set val $header_row_items + set val $header_row_items set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] } -colspans { - set colspans_by_header [my header_colspans] + set colspans_by_header [my header_colspans] set result [tcl::dict::create] set val [tcl::dict::get $colspans_by_header $hidx] #ansireset not required @@ -1391,11 +1412,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set header_ansibase_items [list] ; + set header_ansibase_items [list] ; foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend header_ansibase_items $code @@ -1422,7 +1443,7 @@ tcl::namespace::eval textblock { if {[llength $v] > $numcols} { error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" } - if {[llength $v] < $numcols} { + if {[llength $v] < $numcols} { puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" } @@ -1436,7 +1457,7 @@ tcl::namespace::eval textblock { } if {!$first_is_ok} { error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" - } + } #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) set remaining $firstspan if {$remaining ne "any"} { @@ -1448,7 +1469,7 @@ tcl::namespace::eval textblock { foreach span [lrange $v 1 end] { if {$remaining eq "any"} { if {$span eq "any"} { - set remaining "any" + set remaining "any" } elseif {$span > 0} { #ok to reset to higher val immediately or after an any and any number of following zeros if {$span > ($numcols - $sidx)} { @@ -1458,7 +1479,7 @@ tcl::namespace::eval textblock { set remaining $span incr remaining -1 } else { - #zero following an any - leave remaining as any + #zero following an any - leave remaining as any } } else { if {$span eq "0"} { @@ -1525,7 +1546,7 @@ tcl::namespace::eval textblock { # -- -- -- -- -- -- #also update maxwidthseen & maxheightseen set i 0 - set maxwidthseen 0 + set maxwidthseen 0 #set maxheightseen 0 foreach hdr $thiscol_headers_vertical { lassign [textblock::size $hdr] _w this_header_width _h this_header_height @@ -1546,7 +1567,7 @@ tcl::namespace::eval textblock { } } -colspans { - #sequence has been verified above - we need to split it and store across columns + #sequence has been verified above - we need to split it and store across columns set c 0 ;#column index foreach span $v { set colspans [tcl::dict::get $o_columndefs $c -header_colspans] @@ -1594,7 +1615,7 @@ tcl::namespace::eval textblock { } #set o_headerstate $hidx -minheight? -maxheight? ??? - tcl::dict::set o_headerdefs $hidx $update_hdefs + tcl::dict::set o_headerdefs $hidx $update_hdefs } method add_row {valuelist args} { @@ -1614,14 +1635,14 @@ tcl::namespace::eval textblock { if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { error "add_row - no values supplied, and no columns defined, so cannot use default column values" } - + set defaults [tcl::dict::create\ -minheight 1\ -maxheight ""\ -ansibase ""\ -ansireset "\uFFEF"\ ] - set o_opts_row_defaults $defaults + set o_opts_row_defaults $defaults if {[llength $args] %2 !=0} { error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" @@ -1655,23 +1676,23 @@ tcl::namespace::eval textblock { } } set rowcount [tcl::dict::size $o_rowdefs] - tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure + tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure if {[catch { my configure_row $rowcount {*}$opts } errMsg]} { #undo anything we saved before configure_row tcl::dict::unset o_rowdefs $rowcount - #remove auto_columns + #remove auto_columns if {$auto_columns} { set o_columndata [tcl::dict::create] set o_columndefs [tcl::dict::create] set o_columnstate [tcl::dict::create] } - error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" + error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" } - + set c 0 set max_height_seen 1 foreach v $valuelist { @@ -1753,11 +1774,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set row_ansibase_items [list] ; + set row_ansibase_items [list] ; foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend row_ansibase_items $code @@ -1933,7 +1954,7 @@ tcl::namespace::eval textblock { } method get_column_by_index {index_expression args} { #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" - #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. + #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. set opts [tcl::dict::create\ -position "inner"\ -return "string"\ @@ -1971,7 +1992,7 @@ tcl::namespace::eval textblock { set topt_show_header [tcl::dict::get $o_opts_table -show_header] if {$topt_show_header eq ""} { - set allheaders 0 + set allheaders 0 set all_cols [tcl::dict::keys $o_columndefs] foreach c $all_cols { incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] @@ -1994,8 +2015,8 @@ tcl::namespace::eval textblock { set boxlimits "" set joins "" - set header_boxlimits [list] - set header_body_joins [list] + set header_boxlimits [list] + set header_body_joins [list] set ftypes [my Get_frametypes] @@ -2014,9 +2035,9 @@ tcl::namespace::eval textblock { set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] set header_body_joins [tcl::dict::get $limj bodyjoins] - set joins [tcl::dict::get $limj joins] - set boxlimits_position [tcl::dict::get $limj boxlimits] - set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] + set joins [tcl::dict::get $limj joins] + set boxlimits_position [tcl::dict::get $limj boxlimits] + set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] #use struct::set instead of simple for loop - will be faster at least when critcl available set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] @@ -2039,9 +2060,9 @@ tcl::namespace::eval textblock { set sep_elements_horizontal $::textblock::class::table_hseps set sep_elements_vertical $::textblock::class::table_vseps - set topmap [tcl::dict::get $fmap top$opt_posn] - set botmap [tcl::dict::get $fmap bottom$opt_posn] - set midmap [tcl::dict::get $fmap middle$opt_posn] + set topmap [tcl::dict::get $fmap top$opt_posn] + set botmap [tcl::dict::get $fmap bottom$opt_posn] + set midmap [tcl::dict::get $fmap middle$opt_posn] set onlymap [tcl::dict::get $fmap only$opt_posn] set hdrmap [tcl::dict::get $hmap only${opt_posn}] @@ -2053,7 +2074,7 @@ tcl::namespace::eval textblock { set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] - #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway + #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] lassign [my Get_seps] _h show_seps_h _v show_seps_v @@ -2070,7 +2091,7 @@ tcl::namespace::eval textblock { set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { - set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] + set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] set ansiborder_final $ansibase_header$ansiborder_header$extrabg } else { set ansiborder_final $ansibase_header$ansiborder_header @@ -2078,7 +2099,7 @@ tcl::namespace::eval textblock { set RST [punk::ansi::a] - set hcolwidth $colwidth + set hcolwidth $colwidth #set hcolwidth [my column_width_configured $cidx] set hcell_line_blank [tcl::string::repeat " " $hcolwidth] @@ -2128,7 +2149,7 @@ tcl::namespace::eval textblock { if {$hrow == $hmax} { set header_joins $header_body_joins } else { - set header_joins $joins + set header_joins $joins } if {![tcl::dict::get $o_opts_table -show_edge]} { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] @@ -2146,7 +2167,7 @@ tcl::namespace::eval textblock { set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] set spanbelow [lindex $next_spanlist $cidx] if {$spanbelow == 0} { - #we don't want a down-join for blc - use a framedef with only left joins + #we don't want a down-join for blc - use a framedef with only left joins tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] } } else { @@ -2160,7 +2181,7 @@ tcl::namespace::eval textblock { #May be better to require user to pre-wrap as needed ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] - #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used + #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) # -width is always +2 - as the boxlimits take into account show_vseps and show_edge @@ -2198,10 +2219,10 @@ tcl::namespace::eval textblock { #puts ">> remaining_spans: $remaining_spans" set spancol [expr {$cidx + 1}] set h_lines [lrepeat $rowh ""] - set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + - set last [expr {[llength $remaining_spans] -1}] set i 0 foreach s $remaining_spans { @@ -2217,9 +2238,9 @@ tcl::namespace::eval textblock { set limj [my Get_boxlimits_and_joins $next_posn $fname_body] set span_joins_body [tcl::dict::get $limj bodyjoins] - set span_joins [tcl::dict::get $limj joins] - set span_boxlimits [tcl::dict::get $limj boxlimits] - set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] + set span_joins [tcl::dict::get $limj joins] + set span_boxlimits [tcl::dict::get $limj boxlimits] + set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] #use struct::set instead of simple for loop - will be faster at least when critcl available #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] @@ -2242,14 +2263,14 @@ tcl::namespace::eval textblock { } } else { #join to body - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype } } if {$hrow == $hmax} { set header_joins $span_joins_body } else { - set header_joins $span_joins + set header_joins $span_joins } if {![tcl::dict::get $o_opts_table -show_edge]} { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] @@ -2264,7 +2285,7 @@ tcl::namespace::eval textblock { } else { break } - incr spancol + incr spancol incr i } @@ -2283,7 +2304,7 @@ tcl::namespace::eval textblock { set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] } else { - set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] + set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] } } else { @@ -2328,10 +2349,10 @@ tcl::namespace::eval textblock { set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] #POTENTIAL BUG (fixed with spans_to_rhs above) #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) - #we need to shift 1 to the left when doing our overtype with blockalign right + #we need to shift 1 to the left when doing our overtype with blockalign right #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge #(even though the column position may be left or inner) - + } else { @@ -2368,12 +2389,12 @@ tcl::namespace::eval textblock { set h_lines [lrepeat $padheight $bline] set hcell_blank [::join $h_lines \n] set header_frame $hcell_blank - } else { + } else { set bline [tcl::string::repeat $TSUB $padwidth] set h_lines [lrepeat $rowh $bline] set hcell_blank [::join $h_lines \n] # -usecache 1 ok - #frame borders will never display - so use the simplest frametype and don't apply any ansi + #frame borders will never display - so use the simplest frametype and don't apply any ansi #puts "===>zerospan hlims: $hlims" set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ @@ -2403,13 +2424,13 @@ tcl::namespace::eval textblock { append part_header $header_frame\n } set part_header [tcl::string::trimright $part_header \n] - lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight + lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight set padline [tcl::string::repeat $TSUB $return_headerwidth] - set adjusted_lines [list] + set adjusted_lines [list] foreach ln [split $part_header \n] { if {[tcl::string::first $TSUB $ln] >=0} { - lappend adjusted_lines $padline + lappend adjusted_lines $padline } else { lappend adjusted_lines $ln } @@ -2475,7 +2496,7 @@ tcl::namespace::eval textblock { set cell_ansibase "" set ansiborder_body_col_row $border_ansi$row_bg - set ansiborder_final $ansiborder_body_col_row + set ansiborder_final $ansiborder_body_col_row #$c will always have ansi resets due to overtype behaviour ? #todo - review overtype if {[punk::ansi::ta::detect $c]} { @@ -2493,7 +2514,7 @@ tcl::namespace::eval textblock { #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] #puts --->[ansistring VIEW $codes] - + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { #special case double reset at end of content @@ -2506,7 +2527,7 @@ tcl::namespace::eval textblock { set cell_ansibase $cell_ansi_tail } else { #single trailing reset in content - set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase + set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase } } else { if {$ftblock} { @@ -2534,7 +2555,7 @@ tcl::namespace::eval textblock { } else { set bmap $topmap if {$do_show_header} { - set blims $blims_top + set blims $blims_top } else { set blims $blims_top_headerless } @@ -2610,7 +2631,7 @@ tcl::namespace::eval textblock { } else { set output $part_body } - return $output + return $output } else { return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] } @@ -2631,15 +2652,15 @@ tcl::namespace::eval textblock { } error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" } - #assert cidx is integer >=0 - set num_header_rows [my header_count] - set cdef [tcl::dict::get $o_columndefs $cidx] - set headerlist [tcl::dict::get $cdef -headers] + #assert cidx is integer >=0 + set num_header_rows [my header_count] + set cdef [tcl::dict::get $o_columndefs $cidx] + set headerlist [tcl::dict::get $cdef -headers] set ansibase_col [tcl::dict::get $cdef -ansibase] set textalign [tcl::dict::get $cdef -textalign] switch -- $textalign { left {set pad right} - right {set pad left} + right {set pad left} default { set pad "centre" ;#todo? } @@ -2663,7 +2684,7 @@ tcl::namespace::eval textblock { # lappend configured_widths [my column_width_configured $c] #} - set output [tcl::dict::create] + set output [tcl::dict::create] tcl::dict::set output headers [list] set showing_vseps [my Showing_vseps] @@ -2699,10 +2720,10 @@ tcl::namespace::eval textblock { set headerrow_colspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerrow_colspans $cidx] + set this_span [lindex $headerrow_colspans $cidx] - #set this_hdrwidth [lindex $configured_widths $cidx] - set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign + #set this_hdrwidth [lindex $configured_widths $cidx] + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] @@ -2713,7 +2734,7 @@ tcl::namespace::eval textblock { set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top set hval_block [::join $hval_lines \n] set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] - tcl::dict::lappend output headers $hcell + tcl::dict::lappend output headers $hcell } @@ -2737,7 +2758,7 @@ tcl::namespace::eval textblock { set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] - if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { + if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { set rowh $rowdefminh ;#an exact height is defined for the row } else { if {$rowdefminh eq ""} { @@ -2759,7 +2780,7 @@ tcl::namespace::eval textblock { } } } - + set cell_lines [lrepeat $rowh $cell_line_blank] #set cell_blank [join $cell_lines \n] @@ -2771,7 +2792,7 @@ tcl::namespace::eval textblock { set cval_lines [lrange $cval_lines 0 $rowh-1] set cval_block [::join $cval_lines \n] - #//JMN assert widest cval_line = datawidth = known_blockwidth + #//JMN assert widest cval_line = datawidth = known_blockwidth set cell [textblock::pad $cval_block -known_blockwidth $datawidth -width $datawidth -padchar " " -within_ansi 1 -which $pad] #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] tcl::dict::lappend output cells $cell @@ -2796,7 +2817,7 @@ tcl::namespace::eval textblock { #[call class::table [method debug]] #[para] display lots of debug information about how the table is constructed. - #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) + #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) set defaults [tcl::dict::create\ -usetables 1\ ] @@ -2815,7 +2836,7 @@ tcl::namespace::eval textblock { puts stdout "rowstates: $o_rowstates" #puts stdout "columndefs: $o_columndefs" puts stdout "columndefs:" - if {!$opt_usetables} { + if {!$opt_usetables} { tcl::dict::for {k v} $o_columndefs { puts " $k $v" } @@ -2828,7 +2849,7 @@ tcl::namespace::eval textblock { continue } $t add_column -headers $property - } + } break } @@ -2837,15 +2858,15 @@ tcl::namespace::eval textblock { set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths tcl::dict::for {col coldef} $o_columndefs { set row [list $col] - set colheaders [tcl::dict::get $coldef -headers] + set colheaders [tcl::dict::get $coldef -headers] #inner table probably overkill here ..but just as easy set htable [textblock::class::table new] $htable configure -show_header 1 -show_edge 0 -show_hseps 0 $htable add_column -headers row $htable add_column -headers text $htable add_column -headers WxH - $htable add_column -headers span - set hnum 0 + $htable add_column -headers span + set hnum 0 set spans [tcl::dict::get $o_columndefs $col -header_colspans] foreach h $colheaders s $spans { lassign [textblock::size $h] _w width _h height @@ -2860,7 +2881,7 @@ tcl::namespace::eval textblock { if {$w > [tcl::dict::get $max_widths $icol]} { tcl::dict::set max_widths $icol $w } - incr icol + incr icol } } @@ -2878,7 +2899,7 @@ tcl::namespace::eval textblock { tcl::dict::for {innercol maxw} $max_widths { $htable configure_column $innercol -minwidth $maxw -blockalign left } - lappend row [$htable print] + lappend row [$htable print] $htable destroy } default { @@ -2902,7 +2923,7 @@ tcl::namespace::eval textblock { tcl::dict::for {k coldef} $o_columndefs { if {[tcl::dict::exists $o_columndata $k]} { set headerlist [tcl::dict::get $coldef -headers] - set coldata [tcl::dict::get $o_columndata $k] + set coldata [tcl::dict::get $o_columndata $k] set colinfo "rowcount: [llength $coldata]" set allfields [concat $headerlist $coldata] if {[llength $allfields]} { @@ -2923,7 +2944,7 @@ tcl::namespace::eval textblock { if {$c == 0} { lappend cols [my get_column_by_index $c -position left] " " } elseif {$c == $max} { - lappend cols [my get_column_by_index $c -position right] + lappend cols [my get_column_by_index $c -position right] } else { lappend cols [my get_column_by_index $c -position inner] " " } @@ -3068,7 +3089,7 @@ tcl::namespace::eval textblock { lappend configured_widths [my column_width_configured $c] } set header_colspans [my header_colspans] - set width_max $colwidth + set width_max $colwidth set test_width $colwidth set showing_vseps [my Showing_vseps] set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] @@ -3104,7 +3125,7 @@ tcl::namespace::eval textblock { if {$showing_vseps} { incr others_width 1 } - } + } set total_spanned_width [expr {$width_max + $others_width}] if {$thiscol_widest_header > $total_spanned_width} { #this just allocates the extra space in the current column - which is not great. @@ -3151,9 +3172,9 @@ tcl::namespace::eval textblock { return true } } - return false + return false } - + method column_datawidth {index_expression args} { set opts [tcl::dict::create\ -headers 0\ @@ -3268,11 +3289,11 @@ tcl::namespace::eval textblock { set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] set widest [expr {max($valwidest,$hwidest)}] } else { - set widest $hwidest + set widest $hwidest } return $widest } - #print1 uses basic column joining - useful for testing/debug especially with colspans + #print1 uses basic column joining - useful for testing/debug especially with colspans method print1 {args} { if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] @@ -3317,15 +3338,15 @@ tcl::namespace::eval textblock { incr colposn } if {[llength $blocks]} { - return [textblock::join -- {*}$blocks] + return [textblock::join -- {*}$blocks] } else { return "No columns matched" } } method columncalc_spans {allocmethod} { - set colwidths [tcl::dict::create] ;# to use tcl::dict::incr + set colwidths [tcl::dict::create] ;# to use tcl::dict::incr set colspace_added [tcl::dict::create] - + set ordered_spans [tcl::dict::create] tcl::dict::for {col spandata} [my spangroups] { set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] @@ -3342,7 +3363,7 @@ tcl::namespace::eval textblock { } } tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered - tcl::dict::set colspace_added $col 0 + tcl::dict::set colspace_added $col 0 set spanlengths [tcl::dict::get $spandata spanlengths] foreach slen $spanlengths { @@ -3352,13 +3373,13 @@ tcl::namespace::eval textblock { set hwidth [tcl::dict::get $s headerwidth] set hrow [tcl::dict::get $s hrow] set scol [tcl::dict::get $s startcol] - tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth + tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth } } } - #safe jumptable test + #safe jumptable test #dict for {spanid spandata} $ordered_spans {} tcl::dict::for {spanid spandata} $ordered_spans { lassign [split $spanid ,] startcol hrow @@ -3369,7 +3390,7 @@ tcl::namespace::eval textblock { if {$num_cols_spanned == 1} { set col [lindex $memcols 0] set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] - if {$space_to_alloc > 0} { + if {$space_to_alloc > 0} { set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] if {$maxwidth ne ""} { if {$maxwidth > [tcl::dict::get $colwidths $col]} { @@ -3379,7 +3400,7 @@ tcl::namespace::eval textblock { } set will_alloc [expr {min($space_to_alloc,$can_alloc)}] } else { - set will_alloc $space_to_alloc + set will_alloc $space_to_alloc } if {$will_alloc} { #tcl::dict::set colwidths $col $hwidth @@ -3401,12 +3422,12 @@ tcl::namespace::eval textblock { if {[my Showing_vseps]} { set sepcount [expr {$num_cols_spanned -1}] incr space_to_alloc -$sepcount - } + } #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added switch -- $allocmethod { least { #add to least-expanded each time - #safer than method 1 - pretty balanced + #safer than method 1 - pretty balanced if {$space_to_alloc > 0} { for {set i 0} {$i < $space_to_alloc} {incr i} { set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] @@ -3424,10 +3445,10 @@ tcl::namespace::eval textblock { } } least_unmaxed { - #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth + #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth #(we should be able to collapse column width to zero and have header colspans gracefully respond) #add to least-expanded each time - #safer than method 1 - pretty balanced + #safer than method 1 - pretty balanced if {$space_to_alloc > 0} { for {set i 0} {$i < $space_to_alloc} {incr i} { set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] @@ -3464,7 +3485,7 @@ tcl::namespace::eval textblock { foreach col $ordered_colids { tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col + tcl::dict::incr colspace_added $col incr space_to_alloc -1 if {$space_to_alloc == 0} { break @@ -3500,7 +3521,7 @@ tcl::namespace::eval textblock { foreach col $ordered_colids { tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col + tcl::dict::incr colspace_added $col incr space_to_alloc -1 if {$space_to_alloc == 0} { break @@ -3512,10 +3533,10 @@ tcl::namespace::eval textblock { } - return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] + return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] } - #spangroups keyed by column + #spangroups keyed by column method spangroups {} { #*** !doctools #[call class::table [method spangroups]] @@ -3529,8 +3550,8 @@ tcl::namespace::eval textblock { tcl::dict::set spangroups $c [list spanlengths {}] set spanlist [my column_get_spaninfo $c] set index_spanlen_val 5 - set spanlist [lsort -index $index_spanlen_val -integer $spanlist] - set ungrouped $spanlist + set spanlist [lsort -index $index_spanlen_val -integer $spanlist] + set ungrouped $spanlist while {[llength $ungrouped]} { set spanlen [lindex $ungrouped 0 $index_spanlen_val] @@ -3548,14 +3569,14 @@ tcl::namespace::eval textblock { tcl::dict::set headerwidths $hcol,$hrow $hwidth } lappend spaninfo headerwidth $hwidth - lappend sgroup $spaninfo + lappend sgroup $spaninfo } set spanlengths [tcl::dict::get $spangroups $c spanlengths] lappend spanlengths $spanlen tcl::dict::set spangroups $c spanlengths $spanlengths tcl::dict::set spangroups $c spangroups $spanlen $sgroup set ungrouped [lremove $ungrouped {*}$spangroup_posns] - } + } } return $spangroups } @@ -3639,14 +3660,14 @@ tcl::namespace::eval textblock { basic { #basic column by column - This allocates extra space to first span/column as they're encountered. #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans - #The header values can extend over some of the spanned columns - but not optimally so. + #The header values can extend over some of the spanned columns - but not optimally so. set o_calculated_column_widths [list] for {set c 0} {$c < $column_count} {incr c} { lappend o_calculated_column_widths [my basic_column_width $c] } } simplistic { - #just uses the widest column data or header element. + #just uses the widest column data or header element. #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column #This is a conservative option potentially useful in testing/debugging. set o_calculated_column_widths [list] @@ -3655,7 +3676,7 @@ tcl::namespace::eval textblock { } } span { - #widest of smallest spans first method + #widest of smallest spans first method #set calcresult [my columncalc_spans least] set calcresult [my columncalc_spans least_unmaxed] set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] @@ -3674,7 +3695,7 @@ tcl::namespace::eval textblock { return $o_calculated_column_widths } method print2 {args} { - variable full_column_cache + variable full_column_cache set full_column_cache [tcl::dict::create] if {![llength $args]} { @@ -3728,10 +3749,10 @@ tcl::namespace::eval textblock { tcl::dict::set full_column_cache $c $columninfo } set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] if {$table eq ""} { - set table $nextcol + set table $nextcol set height [textblock::height $table] ;#only need to get height once at start } else { set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] @@ -3741,12 +3762,12 @@ tcl::namespace::eval textblock { #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] } - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3766,7 +3787,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -3818,7 +3839,7 @@ tcl::namespace::eval textblock { } set blocks [list] set numposns [llength $cols] - set colposn 0 + set colposn 0 set padwidth 0 set table "" foreach c $cols { @@ -3834,20 +3855,20 @@ tcl::namespace::eval textblock { } set columninfo [my get_column_by_index $c -return dict {*}$flags] set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] if {$table eq ""} { - set table $nextcol + set table $nextcol set height [textblock::height $table] ;#only need to get height once at start } else { set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] } - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3867,7 +3888,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -3895,7 +3916,7 @@ tcl::namespace::eval textblock { method print {args} { #*** !doctools #[call class::table [method print]] - #[para] Return the table as text suitable for console display + #[para] Return the table as text suitable for console display if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] @@ -3923,7 +3944,7 @@ tcl::namespace::eval textblock { } } set numposns [llength $cols] - set colposn 0 + set colposn 0 set padwidth 0 set header_build "" set body_blocks [list] @@ -3941,7 +3962,7 @@ tcl::namespace::eval textblock { } set columninfo [my get_column_by_index $c -return dict {*}$flags] #set nextcol [tcl::dict::get $columninfo column] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] set headerheight [tcl::dict::get $columninfo headerheight] #set nextcol_lines [split $nextcol \n] #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] @@ -3950,7 +3971,7 @@ tcl::namespace::eval textblock { set nextcol_body [tcl::dict::get $columninfo body] if {$header_build eq "" && ![llength $body_blocks]} { - set header_build $nextcol_header + set header_build $nextcol_header } else { if {$headerheight > 0} { set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] @@ -3958,7 +3979,7 @@ tcl::namespace::eval textblock { #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] } lappend body_blocks $nextcol_body - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {![llength $body_blocks]} { @@ -3993,7 +4014,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -4018,11 +4039,11 @@ tcl::namespace::eval textblock { method print_bodymatrix {} { #*** !doctools #[call class::table [method print_bodymatrix]] - #[para] output the matrix string corresponding to the body data using the matrix 2string format + #[para] output the matrix string corresponding to the body data using the matrix 2string format #[para] this will be a table without borders,headers,title etc and will exclude additional ANSI applied due to table, row or column settings. #[para] If the original cell data itself contains ANSI - the output will still contain those ansi codes. # - + set m [my as_matrix] $m format 2string @@ -4050,12 +4071,12 @@ tcl::namespace::eval textblock { return $frametypes } - tcl::namespace::eval cd { - #todo - save and restore existing tcl::namespace::export in case macros::cd has default exports in future - tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export *} - tcl::namespace::import ::term::ansi::code::macros::cd::* - tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} - } + #tcl::namespace::eval cd { + # #todo - save and restore existing tcl::namespace::export in case macros::cd has default exports in future + # tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export *} + # tcl::namespace::import ::term::ansi::code::macros::cd::* + # tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} + #} proc spantest {} { set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] $t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2] @@ -4077,7 +4098,7 @@ tcl::namespace::eval textblock { return $t } - #more complex colspans + #more complex colspans proc spantest2 {} { set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} @@ -4102,7 +4123,7 @@ tcl::namespace::eval textblock { return $t } - punk::args::definition { + punk::args::define { @id -id ::textblock::periodic @cmd -name textblock::periodic -help "A rudimentary periodic table This is primarily a test of textblock::class::table" @@ -4116,7 +4137,7 @@ tcl::namespace::eval textblock { -show_header -default "" -type boolean -show_edge -default "" -type boolean -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - @values -min 0 -max 0 + @values -min 0 -max 0 } proc periodic {args} { @@ -4142,7 +4163,7 @@ tcl::namespace::eval textblock { " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ - ] + ] set type_colours [list] @@ -4152,71 +4173,71 @@ tcl::namespace::eval textblock { set ansi [a+ {*}$fc web-black Web-gold] set val [list ansi $ansi cat alkaline_earth] foreach e $cat_alkaline_earth { - tcl::dict::set ecat $e $val + tcl::dict::set ecat $e $val } set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - #set ansi [a+ {*}$fc web-black Web-lightgreen] - set ansi [a+ {*}$fc black Term-113] + #set ansi [a+ {*}$fc web-black Web-lightgreen] + set ansi [a+ {*}$fc black Term-113] set val [list ansi $ansi cat reactive_nonmetal] foreach e $cat_reactive_nonmetal { tcl::dict::set ecat $e $val } set cat [list Li Na K Rb Cs Fr] - #set ansi [a+ {*}$fc web-black Web-Khaki] - set ansi [a+ {*}$fc black Term-lightgoldenrod2] + #set ansi [a+ {*}$fc web-black Web-Khaki] + set ansi [a+ {*}$fc black Term-lightgoldenrod2] set val [list ansi $ansi cat alkali_metals] foreach e $cat { tcl::dict::set ecat $e $val } - set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - #set ansi [a+ {*}$fc web-black Web-lightsalmon] - set ansi [a+ {*}$fc black Term-orange1] + set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] + #set ansi [a+ {*}$fc web-black Web-lightsalmon] + set ansi [a+ {*}$fc black Term-orange1] set val [list ansi $ansi cat transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] + set ansi [a+ {*}$fc web-black Web-lightskyblue] set val [list ansi $ansi cat post_transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list B Si Ge As Sb Te At] - #set ansi [a+ {*}$fc web-black Web-turquoise] - set ansi [a+ {*}$fc black Brightcyan] + #set ansi [a+ {*}$fc web-black Web-turquoise] + set ansi [a+ {*}$fc black Brightcyan] set val [list ansi $ansi cat metalloids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] + set ansi [a+ {*}$fc web-black Web-orchid] set val [list ansi $ansi cat noble_gases] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] + set ansi [a+ {*}$fc web-black Web-plum] set val [list ansi $ansi cat actinoids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - #set ansi [a+ {*}$fc web-black Web-tan] - set ansi [a+ {*}$fc black Term-tan] + #set ansi [a+ {*}$fc web-black Web-tan] + set ansi [a+ {*}$fc black Term-tan] set val [list ansi $ansi cat lanthanoids] foreach e $cat { tcl::dict::set ecat $e $val } - set ansi [a+ {*}$fc web-black Web-whitesmoke] + set ansi [a+ {*}$fc web-black Web-whitesmoke] set val [list ansi $ansi cat other] foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { tcl::dict::set ecat $e $val @@ -4243,7 +4264,7 @@ tcl::namespace::eval textblock { set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] set c 0 foreach h $header_0 { - $t configure_column $c -headers [list $h] -minwidth 2 + $t configure_column $c -headers [list $h] -minwidth 2 incr c } set ccount [$t column_count] @@ -4258,7 +4279,7 @@ tcl::namespace::eval textblock { } dict for {k v} $conf { if {[dict get $opts $k] ne ""} { - dict set conf $k [dict get $opts $k] + dict set conf $k [dict get $opts $k] } } @@ -4289,16 +4310,19 @@ tcl::namespace::eval textblock { } proc bookend_lines {block start {end "\x1b\[m"}} { - set out "" + set out "" foreach ln [split $block \n] { append out $start $ln $end \n } return [string range $out 0 end-1] } proc ansibase_lines {block {newprefix ""}} { - set base "" + set base "" set out "" if {$newprefix eq ""} { + if {![punk::ansi::ta::detect $block]} { + return $block + } foreach ln [split $block \n] { set parts [punk::ansi::ta::split_codes $ln] if {[lindex $parts 0] eq ""} { @@ -4316,7 +4340,7 @@ tcl::namespace::eval textblock { set code_idx 3 foreach {pt code} [lrange $parts 2 end] { if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts $code_idx+1 $base] + set parts [linsert $parts $code_idx+1 $base] } incr code_idx 2 } @@ -4325,6 +4349,12 @@ tcl::namespace::eval textblock { return [string range $out 0 end-1] } else { set base $newprefix + if {![punk::ansi::ta::detect $block]} { + foreach ln [split $block \n] { + append out $base $ln \n + } + return $out + } foreach ln [split $block \n] { set parts [punk::ansi::ta::split_codes $ln] set code_idx 1 @@ -4343,7 +4373,7 @@ tcl::namespace::eval textblock { incr offset } incr code_idx 2 - } + } append out {*}$parts \n } return [string range $out 0 end-1] @@ -4351,27 +4381,47 @@ tcl::namespace::eval textblock { } set FRAMETYPES [textblock::frametypes] - punk::args::definition [punk::lib::tstr -return string { + punk::args::define [punk::lib::tstr -return string { @id -id ::textblock::list_as_table @cmd -name "textblock::list_as_table" -help\ "Display a list in a bordered table " -return -default table -choices {table tableobject} + -table -default "" -type string\ + -help "existing table object to use" + -action -default "append" -choices {append replace}\ + -help "row insertion method if existing -table is supplied + if append is chosen the new values will always start at the first column" + -title -type string -help\ + "Title to display overlayed on top edge of table. + Will not be visible if -show_edge is false" + -titlealign -type string -choices {left centre right} -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ - -help "frame type or dict for custom frame" + -help "frame type or dict for custom frame" -show_edge -default "" -type boolean\ -help "show outer border of table" - -show_seps -default "" -type boolean + -show_seps -default "" -type boolean -show_vseps -default "" -type boolean\ - -help "Show vertical table separators" + -help "Show vertical table separators" -show_hseps -default "" -type boolean\ -help "Show horizontal table separators (default 0 if no existing -table supplied)" - -table -default "" -type string\ - -help "existing table object to use" -colheaders -default "" -type list\ - -help "list of lists. list of column header values. Outer list must match number of columns" + -help {list of lists. list of column header values. Outer list must match number of columns. + A table + e.g single header row: -colheaders {{column_a} {column_b} {column_c}} + e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}} + Note that each element of the outer list is itself a list so: + -colheaders {"column a" "column b" "column c"} + Is likely not the right format if it was intended to have a single header row where the + column titles contain spaces. + The correct syntax for that would be: + -colheaders {{"column a"} {"column b"} {"column c"}} + For spanning header cells - use 'set t [list_as_table -return tableobject ...]' + and then something like: + $t configure_header 1 -colspans {3 0 0}; $t print + } -header -default "" -type list -multiple 1\ -help "Each supplied -header argument is a header row. The number of values for each must be <= number of columns" @@ -4379,9 +4429,6 @@ tcl::namespace::eval textblock { -help "Whether to show a header row. Omit for unspecified/automatic, in which case it will display only if -headers list was supplied." - -action -default "append" -choices {append replace}\ - -help "row insertion method if existing -table is supplied - if append is chosen the new values will always start at the first column" -columns -default "" -type integer\ -help "Number of table columns Will default to 2 if not using an existing -table object" @@ -4395,6 +4442,7 @@ tcl::namespace::eval textblock { set argd [punk::args::get_by_id ::textblock::list_as_table $args] set opts [dict get $argd opts] + set received [dict get $argd received] set datalist [dict get $argd values datalist] set existing_table [dict get $opts -table] @@ -4450,14 +4498,14 @@ tcl::namespace::eval textblock { if {[llength $colheaders] < $c+1} { lappend colheaders [lrepeat $r {}] } - set colinfo [lindex $colheaders $c] + set colinfo [lindex $colheaders $c] if {$r > [llength $colinfo]} { set diff [expr {$r - [llength $colinfo]}] lappend colinfo {*}[lrepeat $diff {}] } lappend colinfo $cell lset colheaders $c $colinfo - incr c + incr c } incr r } @@ -4468,15 +4516,15 @@ tcl::namespace::eval textblock { if {![tcl::dict::exists $opts received -show_header]} { set show_header 1 } else { - set show_header [tcl::dict::get $opts -show_header] + set show_header [tcl::dict::get $opts -show_header] } } else { if {![tcl::dict::exists $opts received -show_header]} { set show_header 0 } else { - set show_header [tcl::dict::get $opts -show_header] + set show_header [tcl::dict::get $opts -show_header] } - } + } if {[tcl::string::is integer -strict $opt_columns]} { set cols $opt_columns @@ -4488,7 +4536,7 @@ tcl::namespace::eval textblock { if {[llength $colheaders]} { set cols [llength $colheaders] } else { - set cols 2 ;#seems a reasonable default + set cols 2 ;#seems a reasonable default } } #defaults for new table only @@ -4551,13 +4599,19 @@ tcl::namespace::eval textblock { } $t add_row $row } - #puts stdout $rowdata + if {"-title" in $received} { + $t configure -title [dict get $opts -title] + } + if {"-titlealign" in $received} { + $t configure -titlealign [dict get $opts -titlealign] + } + #puts stdout $rowdata if {[tcl::dict::get $opts -return] eq "table"} { set result [$t print] if {$is_new_table} { $t destroy } - return $result + return $result } else { return $t } @@ -4573,13 +4627,13 @@ tcl::namespace::eval textblock { error "textblock::block blockheight must be a positive integer" } if {$char eq ""} {return ""} - #using tcl::string::length is ok + #using tcl::string::length is ok if {[tcl::string::length $char] == 1} { set row [tcl::string::repeat $char $blockwidth] set mtrx [lrepeat $blockheight $row] return [::join $mtrx \n] } else { - set charblock [tcl::string::map [list \r\n \n] $char] + set charblock [tcl::string::map [list \r\n \n] $char] if {[tcl::string::last \n $charblock] >= 0} { if {$blockwidth > 1} { #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) @@ -4594,10 +4648,47 @@ tcl::namespace::eval textblock { return [::join $mtrx \n] } } - proc testblock {size {colour ""}} { - if {$size <1 || $size > 15} { - error "textblock::testblock only sizes between 1 and 15 inclusive supported" - } + + + punk::args::define { + @id -id ::textblock::testblock + @cmd -name textblock::testblock -help\ + "Create a block of characters size + columns wide and size rows tall. + (which on a terminal will show as a + vertically oriented rectangle due to + cells being taller than their width) + + The characters used are + 123456789ABCDEF + " + -size -type integer\ + -default 15\ + -optional 1\ + -range {1 15} + -direction -default horizontal\ + -choices {horizontal vertical}\ + -help\ + "When rainbow is in the colour list, + this also affects the direction of + colour changes" + @values -min 0 -max 2 + colour -type list -default {} -optional 1 -help\ + "List of Ansi colour names + e.g. testblock 10 {white Red} + produces a block of character 10x10 + with white text on red bacground + + The additional pseudo-color 'rainbow' + is available. + " + } + + proc testblock {args} { + set argd [punk::args::get_by_id ::textblock::testblock $args] + set colour [dict get $argd values colour] + set size [dict get $argd opts -size] + set rainbow_list [list] lappend rainbow_list {30 47} ;#black White lappend rainbow_list {31 46} ;#red Cyan @@ -4609,35 +4700,36 @@ tcl::namespace::eval textblock { lappend rainbow_list {37 40} ;#white Black lappend rainbow_list {black Yellow} lappend rainbow_list red - lappend rainbow_list green + lappend rainbow_list green lappend rainbow_list yellow lappend rainbow_list blue lappend rainbow_list purple - lappend rainbow_list cyan + lappend rainbow_list cyan lappend rainbow_list {white Red} - set rainbow_direction "horizontal" - set vpos [lsearch $colour vertical] - if {$vpos >= 0} { - set rainbow_direction vertical - set colour [lremove $colour $vpos] - } - set hpos [lsearch $colour horizontal] - if {$hpos >=0} { - #horizontal is the default and superfluous but allowed for symmetry - set colour [lremove $colour $hpos] - } - + #set rainbow_direction "horizontal" + #set vpos [lsearch $colour vertical] + #if {$vpos >= 0} { + # set rainbow_direction vertical + # set colour [lremove $colour $vpos] + #} + #set hpos [lsearch $colour horizontal] + #if {$hpos >=0} { + # #horizontal is the default and superfluous but allowed for symmetry + # set colour [lremove $colour $hpos] + #} + set direction [dict get $argd opts -direction] + set chars [list {*}[punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] + set charsubset [lrange $chars 0 $size-1] if {"noreset" in $colour} { set RST "" } else { set RST [a] } - if {"rainbow" in $colour && $rainbow_direction eq "vertical"} { + if {"rainbow" in $colour && $direction eq "vertical"} { #column first - colour change each column set c [::join $charsubset \n] @@ -4645,7 +4737,7 @@ tcl::namespace::eval textblock { for {set i 0} {$i <$size} {incr i} { set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] set ansi [a+ {*}$colour2] - + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] lappend clist ${ansicode}$c$RST } @@ -4656,7 +4748,7 @@ tcl::namespace::eval textblock { } } elseif {"rainbow" in $colour} { #direction must be horizontal - set block "" + set block "" for {set r 0} {$r < $size} {incr r} { set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] set ansi [a+ {*}$colour2] @@ -4671,7 +4763,7 @@ tcl::namespace::eval textblock { set block [tcl::string::trimright $block \n] return $block } else { - #row first - + #row first - set rows [list] foreach ch $charsubset { lappend rows [tcl::string::repeat $ch $size] @@ -4698,7 +4790,7 @@ tcl::namespace::eval textblock { } else { set tw 8 } - set textblock [textutil::tabify::untabify2 $textblock $tw] + set textblock [textutil::tabify::untabify2 $textblock $tw] } if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) @@ -4707,8 +4799,8 @@ tcl::namespace::eval textblock { if {[tcl::string::last \n $textblock] >= 0} { return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } - return [punk::char::ansifreestring_width $textblock] - } + return [punk::char::ansifreestring_width $textblock] + } #gather info about whether ragged (samewidth each line = false) and min width proc widthinfo {textblock} { #backspaces, vertical tabs ? @@ -4722,7 +4814,7 @@ tcl::namespace::eval textblock { } else { set tw 8 } - set textblock [textutil::tabify::untabify2 $textblock $tw] + set textblock [textutil::tabify::untabify2 $textblock $tw] } if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) @@ -4751,7 +4843,7 @@ tcl::namespace::eval textblock { if {[punk::ansi::ta::detect $tl]} { set tl [punk::ansi::ansistripraw $tl] } - return [punk::char::ansifreestring_width $tl] + return [punk::char::ansifreestring_width $tl] } #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. proc string_length_line_max {textblock} { @@ -4772,7 +4864,7 @@ tcl::namespace::eval textblock { proc height {textblock} { #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le - #empty string still has height 1 (at least for left-right/right-left languages) + #empty string still has height 1 (at least for left-right/right-left languages) #vertical tab on a proper terminal should move directly down. #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) @@ -4802,7 +4894,7 @@ tcl::namespace::eval textblock { #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } else { - set width [punk::char::ansifreestring_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list #our concept of block-height is likely to be different to other line-counting mechanisms @@ -4841,7 +4933,7 @@ tcl::namespace::eval textblock { } } else { set num_le 0 - set width [punk::char::ansifreestring_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } #set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list #our concept of block-height is likely to be different to other line-counting mechanisms @@ -4918,14 +5010,14 @@ tcl::namespace::eval textblock { # -- --- --- --- --- --- --- --- --- --- set padchar [tcl::dict::get $opts -padchar] #if padchar width (screen width) > 1 - length calculations will not be correct - #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map + #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map #The caller may also use ansi within the padchar - although it's unlikely to be efficient. # -- --- --- --- --- --- --- --- --- --- set known_whiches [list l left r right c center centre] set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] switch -- $opt_which { center - centre - c { - set which c + set which c } left - l { set which l @@ -4963,7 +5055,7 @@ tcl::namespace::eval textblock { set known_samewidth [tcl::dict::get $opts -known_samewidth] ;# if true - we have a known non-ragged block, if false - could be either. set datawidth "" if {$width eq "auto"} { - #for auto - we + #for auto - we if {$known_blockwidth eq ""} { if {$known_samewidth ne "" && $known_samewidth} { set datawidth [textblock::widthtopline $block] @@ -4982,10 +5074,10 @@ tcl::namespace::eval textblock { #only call width functions if known_samewidth - otherwise let the pad algorithm below determine it as we go if {$known_samewidth ne "" && $known_samewidth} { if {$known_blockwidth eq ""} { - set datawidth [textblock::widthtopline $block + set datawidth [textblock::widthtopline $block] } else { set datawidth $known_blockwidth - } + } } #assert datawidth may still be empty string } @@ -5004,7 +5096,7 @@ tcl::namespace::eval textblock { #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) #we should use overtype with suitable replacement char (space?) for chopped double-wides if {!$pad_has_ansi} { - return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] + return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] } else { set base [tcl::string::repeat " " $width] return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] @@ -5013,7 +5105,7 @@ tcl::namespace::eval textblock { #review - tcl format can only pad with zeros or spaces? #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - #review - surprisingly, this doesn't seem to be a performance win + #review - surprisingly, this doesn't seem to be a performance win #No detectable diff on small blocks - slightly worse on large blocks # if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { # #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position @@ -5052,7 +5144,7 @@ tcl::namespace::eval textblock { set parts [list $block] } - set line_chunks [list] + set line_chunks [list] set line_len 0 set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad foreach {pt ansi} $parts { @@ -5087,7 +5179,7 @@ tcl::namespace::eval textblock { set pad [tcl::dict::get $pad_cache $missing] } else { set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { + if {!$pad_has_ansi} { set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] } else { set base [tcl::string::repeat " " $missing] @@ -5145,7 +5237,7 @@ tcl::namespace::eval textblock { } #don't let trailing empty ansi affect the line_chunks length if {$ansi ne ""} { - lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? + lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? } } #pad last line @@ -5159,7 +5251,7 @@ tcl::namespace::eval textblock { set pad [tcl::dict::get $pad_cache $missing] } else { set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { + if {!$pad_has_ansi} { set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] } else { set base [tcl::string::repeat " " $missing] @@ -5229,7 +5321,7 @@ tcl::namespace::eval textblock { if {$i == $i_last_code} { return [lappend out $str {*}[lrange $ansisplits $i end]] } - #code being empty can only occur when we have reached last pt + #code being empty can only occur when we have reached last pt #we have returned by then. lappend out $code incr i 2 @@ -5246,7 +5338,7 @@ tcl::namespace::eval textblock { set right1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 1] set right2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 2] - set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] + set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] set t [textblock::list_as_table -columns 3 -return tableobject $testlist] $t configure_column 0 -headers [list "ansi"] @@ -5305,20 +5397,20 @@ tcl::namespace::eval textblock { set r3 [list "column\ncolours"] #1 - #test without table padding + #test without table padding #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering #(basically a mechanism to add extra resets at start and end of each line) #dict for {b bdict} $blockinfo { # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] - # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] + # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] #} #2 - the more useful one? tcl::dict::for {b bdict} $blockinfo { lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] - lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] + lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] lappend r3 "" "" } @@ -5394,7 +5486,7 @@ tcl::namespace::eval textblock { # >} .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| # >} punk::lib::list_as_lines -- } .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } punk::lib::list_as_lines -- } .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| - # >} punk::lib::list_as_lines } punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] set testblock [textblock::testblock 15 rainbow] - set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] + set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] - } + } proc example {args} { @@ -5838,7 +5930,7 @@ tcl::namespace::eval textblock { set RST [a] set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] set punks [textblock::join -- $pleft $pright] - set pleft_greenb $greenb$pleft$RST + set pleft_greenb $greenb$pleft$RST set pright_redb $redb$pright$RST set prightair_cyanb $cyanb$prightair$RST set cpunks [textblock::join -- $pleft_greenb $pright_redb] @@ -5848,7 +5940,16 @@ tcl::namespace::eval textblock { append out [textblock::join -- $punks $cpunks] \n set 2frames_a [textblock::join -- [textblock::frame -checkargs 0 $cpunks] [textblock::frame -checkargs 0 $punks]] append out $2frames_a \n - set 2frames_b [textblock::join -- [textblock::frame -checkargs 0 -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -checkargs 0 -ansiborder $greenb -title "fancypunks" $cpunks]] + set 2frames_b [textblock::join --\ + [textblock::frame -checkargs 0 -ansiborder $cyanb\ + -title "plainpunks" $punks]\ + [textblock::frame -checkargs 0 -ansiborder $greenb\ + -title "fancy"\ + -titlealign right\ + -subtitle "punks"\ + -subtitlealign left\ + $cpunks]\ + ] append out [textblock::frame -checkargs 0 -title "punks" $2frames_b\n$RST$2frames_a] \n set punkdeck [overtype::right [overtype::left [textblock::frame -checkargs 0 -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nD\nE\nC\nK"] set spantable [[spantest] print] @@ -5873,13 +5974,40 @@ tcl::namespace::eval textblock { [>punk . rhs]\ [punk::lib::list_as_lines -- [lrepeat 8 " | "]] } + punk::args::define [punk::lib::tstr -return string { + @id -id ::textblock::table + @cmd -name "textblock::table" -help\ + "A wrapper for creating a textblock::class::table + + NOTE: more options available - argument definition + is incomplete" + @opts + -return -choices {table tableobject} + -rows -type list -default "" -help\ + "A list of lists. + Each toplevel element represents a row. + The number of elements in each row must + be the same. + e.g for 2 rows and 3 columns: + table -rows {{r0c0 r0c1 r0c2} {r1c0 r1c1 r1c2}} + " + -headers -type list -default "" -help\ + "This is a simplified form where each column + has a single header row. + Each element in this list goes into the top + header row for a column. + More complex header arrangements where each + column has multiple headers can be made + by using -return tableobject and calling + $tableobj configure_column -headers" + }] proc table {args} { #todo - use punk::args upvar ::textblock::class::opts_table_defaults toptdefaults set defaults [tcl::dict::create\ -rows [list]\ -headers [list]\ - -return string\ + -return table\ ] @@ -5916,7 +6044,7 @@ tcl::namespace::eval textblock { - if {$opt_return eq "string"} { + if {$opt_return eq "table"} { set result [$t print] $t destroy return $result @@ -5963,7 +6091,7 @@ tcl::namespace::eval textblock { } } } - } + } variable framedef_cache [tcl::dict::create] proc framedef {args} { #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. @@ -5971,7 +6099,7 @@ tcl::namespace::eval textblock { #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. #the arc set can't even join to itself e.g with curved equivalents of T-like shapes - #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. + #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. variable framedef_cache set cache_key $args if {[tcl::dict::exists $framedef_cache $cache_key]} { @@ -6014,10 +6142,10 @@ tcl::namespace::eval textblock { if {![llength $rawglobs] || "all" in $rawglobs || "*" in $rawglobs} { set globs * } else { - set globs [list] + set globs [list] foreach g $rawglobs { switch -- $g { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - + hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - hltj - hlbj - vllj - vlrj { lappend globs $g } @@ -6049,7 +6177,7 @@ tcl::namespace::eval textblock { } default { #must look like a glob search if not one of the above - if {[regexp {[*?\[\]]} $g]} { + if {[regexp {[*?\[\]]} $g]} { lappend globs $g } else { set bad_option 1 @@ -6073,7 +6201,7 @@ tcl::namespace::eval textblock { -help "-boxonly true restricts results to the corner,vertical and horizontal box elements It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - @values -min 1 + @values -min 1 frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ -help "name from the predefined frametypes or an adhoc dictionary." memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { @@ -6090,7 +6218,7 @@ tcl::namespace::eval textblock { set joins [tcl::dict::get $opts -joins] set boxonly [tcl::dict::get $opts -boxonly] - + #sorted order down left right up #1 x choose 4 #4 x choose 3 @@ -6103,7 +6231,7 @@ tcl::namespace::eval textblock { #e.g down-light, up-heavy set join_targets [tcl::dict::create left "" down "" right "" up ""] foreach jt $joins { - lassign [split $jt -] direction target + lassign [split $jt -] direction target if {$target ne ""} { tcl::dict::set join_targets $direction $target } @@ -6116,18 +6244,24 @@ tcl::namespace::eval textblock { switch -- $f { "altg" { #old style ansi escape sequences with alternate graphics page G0 - set hl [cd::hl] + #set hl [cd::hl] + set hl [punk::ansi::g0 q] set hlt $hl set hlb $hl - set vl [cd::vl] + #set vl [cd::vl] + set vl [punk::ansi::g0 x] set vll $vl set vlr $vl - set tlc [cd::tlc] - set trc [cd::trc] - set blc [cd::blc] - set brc [cd::brc] - - #horizontal and vertical bar joins + #set tlc [cd::tlc] + set tlc [punk::ansi::g0 l] + #set trc [cd::trc] + set trc [punk::ansi::g0 k] + #set blc [cd::blc] + set blc [punk::ansi::g0 m] + #set brc [cd::brc] + set brc [punk::ansi::g0 j] + + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6275,7 +6409,7 @@ tcl::namespace::eval textblock { set trc + set blc + set brc + - #horizontal and vertical bar joins + #horizontal and vertical bar joins #set hltj $hlt #set hlbj $hlb #set vllj $vll @@ -6285,7 +6419,7 @@ tcl::namespace::eval textblock { set hlbj + set vllj + set vlrj + - #our corners are all + already - so we won't do anything for directions or targets + #our corners are all + already - so we won't do anything for directions or targets } "light" { @@ -6301,7 +6435,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_lur] set brc [punk::char::charshort boxd_lul] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6316,16 +6450,16 @@ tcl::namespace::eval textblock { #default empty targets to current box type 'light' foreach dir {down left right up} { set rawtarget [tcl::dict::get $join_targets $dir] - lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same + lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same switch -- $target { "" - light { - set target$dir light + set target$dir light } ascii - altg - arc { - set target$dir light + set target$dir light } heavy { - set target$dir $target + set target$dir $target } default { set target$dir other @@ -6397,7 +6531,7 @@ tcl::namespace::eval textblock { other-light { set blc \u2534 ;#(btj) set tlc \u252c ;#(ttj) - #brc - default corner + #brc - default corner set vllj \u2524 ;# (rtj) } other-other { @@ -6439,7 +6573,7 @@ tcl::namespace::eval textblock { light-other { set blc \u251c ;# (ltj) #tlc - default corner - set brc \u2524 ;# boxd_lvl (rtj) + set brc \u2524 ;# boxd_lvl (rtj) set hlbj \u252c ;# (ttj) } light-heavy { @@ -6575,41 +6709,41 @@ tcl::namespace::eval textblock { light_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } light_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] tcl::dict::with arcframe {} ;#extract keys as vars } "heavy" { @@ -6624,7 +6758,7 @@ tcl::namespace::eval textblock { set trc [punk::char::charshort boxd_hdl] set blc [punk::char::charshort boxd_hur] set brc [punk::char::charshort boxd_hul] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6636,10 +6770,10 @@ tcl::namespace::eval textblock { set target [tcl::dict::get $join_targets $dir] switch -- $target { "" - heavy { - set target$dir heavy + set target$dir heavy } light - ascii - altg - arc { - set target$dir light + set target$dir light } default { set target$dir other @@ -6666,12 +6800,12 @@ tcl::namespace::eval textblock { #2 switch -- $targetleft { light { - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) set vllj \u2528 ;# left light (rtj) } heavy { - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) set blc [punk::char::charshort boxd_huhz] ;# (btj) set vllj \u252b ;#(rtj) } @@ -6726,7 +6860,7 @@ tcl::namespace::eval textblock { set vllj \u2528 ;# left light (rtj) } down-light-left-light { - set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) + set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) set hlbj \u252F ;# down light (ttj) @@ -6847,41 +6981,41 @@ tcl::namespace::eval textblock { heavy_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } heavy_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] tcl::dict::with arcframe {} ;#extract keys as vars } "double" { @@ -6897,7 +7031,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7056,7 +7190,7 @@ tcl::namespace::eval textblock { } left_right { #8 - + #from 2 #set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) set tlc \U2566 ;# (ttj) @@ -7147,7 +7281,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7159,7 +7293,7 @@ tcl::namespace::eval textblock { set target [tcl::dict::get $join_targets $dir] switch -- $target { "" - arc { - set target$dir self + set target$dir self } default { set target$dir other @@ -7175,7 +7309,7 @@ tcl::namespace::eval textblock { set blc \u251c ;# *light (ltj) #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable - #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal + #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal #set brc \u2524 ;# *light(rtj) #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) @@ -7247,41 +7381,41 @@ tcl::namespace::eval textblock { arc_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } arc_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] tcl::dict::with arcframe {} ;#extract keys as vars } block1 { @@ -7295,7 +7429,7 @@ tcl::namespace::eval textblock { set blc \u2594 ;# upper one eighth block set brc \u2594 ;# upper one eight block - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7303,7 +7437,7 @@ tcl::namespace::eval textblock { } block2 { - #the resultant table will have text appear towards top of each box + #the resultant table will have text appear towards top of each box #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps set hlt \u2594 ;# upper one eighth block set hlb \u2581 ;# lower one eighth block @@ -7318,17 +7452,19 @@ tcl::namespace::eval textblock { set trc \U1fb7e ;#legacy block set blc \U1fb7c ;#legacy block set brc \U1fb7f ;#legacy block - - if {[punk::console::check::has_bug_legacysymbolwidth]} { - #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems - set sp \u00a0 ;#non breaking space (plain space may act transparent in some use cases) - set tlc $sp - set trc $sp - set blc $sp - set brc $sp + + if {(![interp issafe])} { + if {![catch {punk::console::check::has_bug_legacysymbolwidth} symbug] && $symbug} { + #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems + set sp \u00a0 ;#non breaking space (plain space may act transparent in some use cases) + set tlc $sp + set trc $sp + set blc $sp + set brc $sp + } } - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7336,7 +7472,7 @@ tcl::namespace::eval textblock { } block2hack { - #the resultant table will have text appear towards top of each box + #the resultant table will have text appear towards top of each box #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps set hlt \u2594 ;# upper one eighth block set hlb \u2581 ;# lower one eighth block @@ -7357,7 +7493,7 @@ tcl::namespace::eval textblock { # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) #this hack has a reasonable chance of working - #except that the punk overtype library does recognise PMs + #except that the punk overtype library does recognise PMs #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block @@ -7365,7 +7501,7 @@ tcl::namespace::eval textblock { set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7382,7 +7518,7 @@ tcl::namespace::eval textblock { set blc \u2599 set brc \u259f - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7417,9 +7553,9 @@ tcl::namespace::eval textblock { set $t [tcl::dict::get $custom_frame $t] } else { #set more explicit type to it's more general counterpart if it's missing - #e.g hlt -> hl - #e.g hltj -> hlt - set $t [set [string range $t 0 end-1]] + #e.g hlt -> hl + #e.g hltj -> hlt + set $t [set [string range $t 0 end-1]] } } #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set @@ -7452,26 +7588,106 @@ tcl::namespace::eval textblock { variable frame_cache set frame_cache [tcl::dict::create] - punk::args::definition { + punk::args::define { @id -id ::textblock::frame_cache @cmd -name textblock::frame_cache -help\ "Display or clear the frame cache." - -action -default {} -choices {clear} -help\ - "Clear the textblock::frame_cache dictionary" -pretty -default 1 -help\ - "Use 'pdict textblock::frame_cache */*' for prettier output" - @values -min 0 -max 0 + "Uses 'pdict textblock::frame_cache */*' for prettier output + Either way this is set, output requires long lines and may + still wrap in an ugly manner. Try 'textblock::use_cache md5' + to shorten the argument display and reduce wrapping. + " + @values -min 0 -max -1 + action -default {display} -choices {clear size info display} -choicelabels { + clear "Clear the textblock::frame_cache dictionary." + } -help "Perform an action on the frame cache." } proc frame_cache {args} { set argd [punk::args::get_by_id ::textblock::frame_cache $args] - set action [dict get $argd opts -action] - - if {$action ni [list clear ""]} { - error "frame_cache action '$action' not understood. Valid actions: clear" + set action [dict get $argd values action] + variable frame_cache + set all_values_dict [dict get $argd values] + set action_values [lrange [dict values $all_values_dict] 1 end] + switch -- $action { + clear { + set size [dict size $frame_cache] + set frame_cache [tcl::dict::create] + return "frame_cache cleared $size entries" + } + size { + return [dict size $frame_cache] + } + info { + return [dict info $frame_cache] + } + display { + #fall through + } + default { + #assert - unreachable - punk::args should have validated + error "frame_cache -action '$action' not understood. Valid actions: clear size info display" + } + } + if {[llength $action_values]} { + return [frame_cache_display -pretty [dict get $argd opts -pretty] {*}$action_values] + } else { + return [frame_cache_display -pretty [dict get $argd opts -pretty]] } + } + punk::args::define { + @dynamic + @id -id ::textblock::frame_cache_display + @opts + ${[::punk::args::resolved_def -types opts ::textblock::frame_cache -pretty]} + @values -min 0 -max 2 + startindex -default "" -type indexexpression -help\ + "If both startindex and endindex are missing/empty, it is treated as + startindex 0 endindex end. (ie displays all records) + If only startindex has a value - the frame_cache record at that + index will be displayed" + endindex -default "" -type indexexpression + } + proc frame_cache_display {args} { + set argd [punk::args::get_by_id ::textblock::frame_cache_display $args] variable frame_cache + lassign [dict values [dict get $argd values]] startidx endidx + set limit "" + if {$startidx ne ""} { + if {$endidx ne ""} { + if {$startidx eq $endidx} { + set limit "index" + } else { + set limit "range" + } + } else { + set limit "index" + } + } else { + set limit "all" + } + + set display_dict {} + switch -- $limit { + all { + set display_dict $frame_cache + } + index { + set k [lindex [dict keys $frame_cache] $startidx] + if {$k ne ""} { + set display_dict [dict create $k [dict get $frame_cache $k]] + } + } + range { + set keys [lrange [dict keys $frame_cache] $startidx $endidx] + foreach k $keys { + dict set display_dict $k [dict get $frame_cache $k] + } + } + } + if {[dict get $argd opts -pretty]} { - set out [pdict -chan none frame_cache */*] + set out [pdict -chan none display_dict */*] } else { set out "" if {[catch { @@ -7480,16 +7696,16 @@ tcl::namespace::eval textblock { set termwidth 80 } - tcl::dict::for {k v} $frame_cache { + tcl::dict::for {k v} $display_dict { lassign $v _f frame _used used - set fwidth [textblock::widthtopline $frame] - #review - are cached frames uniform width lines? + set fwidth [textblock::widthtopline $frame] + #review - are cached frames uniform width lines? #set fwidth [textblock::width $frame] set frameinfo "$k used:$used " set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] if {$allinone_width >= $termwidth} { #split across 2 lines - append out "$frameinfo\n" + append out "$frameinfo\n" append out $frame \n } else { append out [textblock::join -- $frameinfo $frame]\n @@ -7497,10 +7713,6 @@ tcl::namespace::eval textblock { append out \n ;# frames used to build tables often have joins - keep a line in between for clarity } } - if {$action eq "clear"} { - set frame_cache [tcl::dict::create] - append out \nCLEARED - } return $out } @@ -7522,7 +7734,7 @@ tcl::namespace::eval textblock { set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] return $FRAMETYPELABELS } - #proc EG {} "return {[a+ brightblack]}" + #proc EG {} "return {[a+ brightblack]}" #make EG fetch from SGR cache so as to abide by colour off/on proc EG {} { a+ brightblack @@ -7536,14 +7748,15 @@ tcl::namespace::eval textblock { # ${[textblock::frame_samples]} #todo punk::args alias for centre center etc? - punk::args::definition -dynamic 1 { + punk::args::define { + @dynamic @id -id ::textblock::frame @cmd -name "textblock::frame"\ -help "Frame a block of text with a border." -checkargs -default 1 -type boolean\ -help "If true do extra argument checks and provide more comprehensive error info. - Set false for slight performance improvement." + Set false for slight performance improvement." -etabs -default 0\ -help "expanding tabs - experimental/unimplemented." -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ @@ -7555,15 +7768,17 @@ tcl::namespace::eval textblock { passing an empty string will result in no box, but title/subtitle will still appear if supplied. ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" -boxmap -default {} -type dict - -joins -default {} -type list + -joins -default {} -type list -title -default "" -type string -regexprefail {\n}\ -help "Frame title placed on topbar - no newlines. - May contain ANSI - no trailing reset required. + May contain ANSI - no trailing reset required. ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" + -titlealign -default "centre" -choices {left centre right} -subtitle -default "" -type string -regexprefail {\n}\ -help "Frame subtitle placed on bottombar - no newlines May contain Ansi - no trailing reset required." + -subtitlealign -default "centre" -choices {left centre right} -width -default "" -type int\ -help "Width of resulting frame including borders. If omitted or empty-string, the width will be determined automatically based on content." @@ -7590,7 +7805,7 @@ tcl::namespace::eval textblock { -help "Show ANSI control characters within frame contents. (Control Representation Mode) Frame width doesn't adapt and content may be truncated - so -width may need to be manually set to display more." + so -width may need to be manually set to display more." @values -min 0 -max 1 contents -default "" -type string\ @@ -7605,7 +7820,7 @@ tcl::namespace::eval textblock { # #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? - #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand + #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it # - but we would need to maintain support for the rendered-string based operations too. proc frame {args} { @@ -7620,7 +7835,9 @@ tcl::namespace::eval textblock { -boxmap {}\ -joins [list]\ -title ""\ + -titlealign "centre"\ -subtitle ""\ + -subtitlealign "centre"\ -width ""\ -height ""\ -ansiborder ""\ @@ -7638,8 +7855,8 @@ tcl::namespace::eval textblock { # for ansi art - -pad 0 is likely to be preferable set has_contents 0 - set optlist $args ;#initial only - content will be removed - #no solo opts for frame + set optlist $args ;#initial only - content will be removed + #no solo opts for frame if {[llength $args] %2 == 0} { if {[lindex $args end-1] eq "--"} { set contents [lpop optlist end] @@ -7653,7 +7870,7 @@ tcl::namespace::eval textblock { set contents [lpop optlist end] set has_contents 1 } - + #todo args -justify left|centre|right (center) #todo -blockalignbias -textalignbias? #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache @@ -7662,12 +7879,12 @@ tcl::namespace::eval textblock { foreach {k v} $optlist { set k2 [tcl::prefix::match -error "" $optnames $k] switch -- $k2 { - -etabs - -type - -boxlimits - -boxmap - -joins - - -title - -subtitle - -width - -height + -etabs - -type - -boxlimits - -boxmap - -join + - -title - -titlealign - -subtitle - -subtitlealign - -width - -height - -ansiborder - -ansibase - -blockalign - -textalign - -ellipsis - -crm_mode - - -usecache - -buildcache - -pad + - -usecache - -buildcache - -pad - -checkargs { tcl::dict::set opts $k2 $v } @@ -7688,21 +7905,21 @@ tcl::namespace::eval textblock { set contents [dict get $argd values contents] } - # -- --- --- --- --- --- + # -- --- --- --- --- --- # cache relevant set opt_usecache [tcl::dict::get $opts -usecache] set opt_buildcache [tcl::dict::get $opts -buildcache] set usecache $opt_usecache ;#may need to override set opt_etabs [tcl::dict::get $opts -etabs] ;#affects contentwidth - needed before cache determination set opt_crm_mode [tcl::dict::get $opts -crm_mode] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_type [tcl::dict::get $opts -type] set opt_boxlimits [tcl::dict::get $opts -boxlimits] set opt_joins [tcl::dict::get $opts -joins] set opt_boxmap [tcl::dict::get $opts -boxmap] set buildcache $opt_buildcache set opt_pad [tcl::dict::get $opts -pad] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_title [tcl::dict::get $opts -title] set opt_subtitle [tcl::dict::get $opts -subtitle] set opt_width [tcl::dict::get $opts -width] @@ -7740,7 +7957,7 @@ tcl::namespace::eval textblock { ##e.g down-light, up-heavy #set join_targets [tcl::dict::create left "" down "" right "" up ""] #foreach jt $opt_joins { - # lassign [split $jt -] direction target + # lassign [split $jt -] direction target # if {$target ne ""} { # tcl::dict::set join_targets $direction $target # } @@ -7832,6 +8049,10 @@ tcl::namespace::eval textblock { package require sha1 set hash [sha1::sha1 [encoding convertto utf-8 $hashables]] } + sha256 { + package require sha256 + set hash [sha2::sha256 [encoding convertto utf-8 $hashables]] + } md5 { package require md5 if {[package vsatisfies [package present md5] 2- ] } { @@ -7840,7 +8061,7 @@ tcl::namespace::eval textblock { set hash [md5::md5 [encoding convertto utf-8 $hashables]] } } - none { + default { set hash $hashables } } @@ -7862,10 +8083,10 @@ tcl::namespace::eval textblock { set FSUB \uF2DD - #this occurs commonly in table building with colspans - review - if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { + #this occurs commonly in table building with colspans - review + if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { set usecache 0 - #set buildcache 0 ;#comment out for debug/analysis so we can see + #set buildcache 0 ;#comment out for debug/analysis so we can see #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" set cache_key [a+ Web-red web-white]$cache_key[a] } @@ -7875,7 +8096,7 @@ tcl::namespace::eval textblock { #we can still substitute with right length set cache_key [a+ Web-steelblue web-black]$cache_key[a] } else { - #actual_contentwidth is narrower than frame - check template's patternwidth + #actual_contentwidth is narrower than frame - check template's patternwidth if {[tcl::dict::exists $frame_cache $cache_key]} { set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] } else { @@ -7902,7 +8123,7 @@ tcl::namespace::eval textblock { set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] set template [tcl::dict::get $frame_cache $cache_key frame] set used [tcl::dict::get $frame_cache $cache_key used] - tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record + tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record set is_cached 1 } @@ -7913,7 +8134,7 @@ tcl::namespace::eval textblock { # -- --- --- --- --- set is_joins_ok 1 foreach v $opt_joins { - lassign [split $v -] direction target + lassign [split $v -] direction target switch -- $direction { left - right - up - down {} default { @@ -7932,7 +8153,7 @@ tcl::namespace::eval textblock { if {!$is_joins_ok} { error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" } - # -- --- --- --- --- --- + # -- --- --- --- --- --- set is_boxmap_ok 1 tcl::dict::for {boxelement subst} $opt_boxmap { switch -- $boxelement { @@ -7945,9 +8166,9 @@ tcl::namespace::eval textblock { } } if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" + error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" } - # -- --- --- --- --- --- + # -- --- --- --- --- --- #these are all valid commands for overtype:: switch -- $opt_textalign { left - right - centre - center {} @@ -7955,7 +8176,7 @@ tcl::namespace::eval textblock { error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" } } - # -- --- --- --- --- --- + # -- --- --- --- --- --- switch -- $opt_blockalign { left - right - centre - center {} default { @@ -8023,7 +8244,7 @@ tcl::namespace::eval textblock { switch -- $frameset { custom { #REVIEW - textblock::table assumes that at least the vl elements are 1-wide - #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though + #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely set vll_width [punk::ansi::printing_length $vll] set hlb_width [punk::ansi::printing_length $hlb] @@ -8041,8 +8262,8 @@ tcl::namespace::eval textblock { if {$opt_width eq ""} { #width wasn't specified - so user is expecting frame to adapt to title/contents #content shouldn't truncate because of extra wide frame - #review - punk::console::get_size ? wrapping? quite hard to support with colspans - set frame_inner_width $content_or_title_width + #review - punk::console::get_size ? wrapping? quite hard to support with colspans + set frame_inner_width $content_or_title_width set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] } else { @@ -8085,14 +8306,16 @@ tcl::namespace::eval textblock { } altg { set tbar [tcl::string::repeat $hlt $frame_inner_width] - set tbar [cd::groptim $tbar] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - set bbar [cd::groptim $bbar] + #set tbar [cd::groptim $tbar] + set tbar [punk::ansi::groptim $tbar] + set bbar [tcl::string::repeat $hlb $frame_inner_width] + #set bbar [cd::groptim $bbar] + set bbar [punk::ansi::groptim $bbar] } default { set tbar [tcl::string::repeat $hlt $frame_inner_width] set bbar [tcl::string::repeat $hlb $frame_inner_width] - + } } @@ -8199,12 +8422,24 @@ tcl::namespace::eval textblock { } if {$opt_title ne ""} { - set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off + set titlealign [dict get $opts -titlealign] + set titlealignfull [tcl::prefix::match -error "" {left centre right} $titlealign] + if {$titlealignfull ni {left centre right}} { + error "textblock::frame -titlealign must be one of {left centre right} or a unique prefix thereof. Received $titlealign" + } + #set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off + set topbar [overtype::block -blockalign $titlealignfull -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 $tbar $opt_title] ;#overtype supports gx0 on/off } else { set topbar $tbar } if {$opt_subtitle ne ""} { - set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off + set titlealign [dict get $opts -subtitlealign] + set titlealignfull [tcl::prefix::match -error "" {left centre right} $titlealign] + if {$titlealignfull ni {left centre right}} { + error "textblock::frame -subtitlealign must be one of {left centre right} or a unique prefix thereof. Received $titlealign" + } + #set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off + set bottombar [overtype::block -blockalign $titlealignfull -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 $bbar $opt_subtitle] ;#overtype supports gx0 on/off } else { set bottombar $bbar } @@ -8259,7 +8494,7 @@ tcl::namespace::eval textblock { #after overtype::block - our actual patternwidth may be less set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] - if {$leftborder && $rightborder} { + if {$leftborder && $rightborder} { #set bodyparts [list $lhs $inner $rhs] set cache_bodyparts [list $lhs $cache_inner $rhs] } else { @@ -8314,12 +8549,12 @@ tcl::namespace::eval textblock { } set template $fscached ;#end !$is_cached - } + } - #use the same mechanism to build the final frame - whether from cache or template + #use the same mechanism to build the final frame - whether from cache or template if {$actual_contentwidth == 0} { set fs [tcl::string::map [list $FSUB " "] $template] } else { @@ -8341,7 +8576,7 @@ tcl::namespace::eval textblock { #set cwidth [textblock::width $contents] set cwidth $actual_contentwidth if {$opt_pad} { - set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) + set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) set paddedwidth [textblock::widthtopline $paddedcontents] #review - horizontal truncation if {$paddedwidth > $cache_patternwidth} { @@ -8382,7 +8617,7 @@ tcl::namespace::eval textblock { if {$is_cached} { - return $fs + return $fs } else { if {$buildcache} { tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] @@ -8390,7 +8625,7 @@ tcl::namespace::eval textblock { return $fs } } - punk::args::definition { + punk::args::define { @id -id ::textblock::gcross -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block Only cross sizes that divide the size of the overall block will be used. @@ -8413,9 +8648,9 @@ tcl::namespace::eval textblock { set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] #set fit_size [punk::lib::greatestOddFactor $size] - set fit_size $size + set fit_size $size if {$opt_max_cross_size == 0} { - set max_cross_size $fit_size + set max_cross_size $fit_size } else { #todo - only allow divisors #set testsize [expr {min($fit_size,$opt_max_cross_size)}] @@ -8443,7 +8678,7 @@ tcl::namespace::eval textblock { set onecross "" set crossrows [list] set armsize [expr {int(floor($max_cross_size /2))}] - set row [lrepeat $max_cross_size " "] + set row [lrepeat $max_cross_size " "] #toparm for {set i 0} {$i < $armsize} {incr i} { set r $row @@ -8484,7 +8719,7 @@ tcl::namespace::eval textblock { return $out } - #Test we can join two coloured blocks + #Test we can join two coloured blocks proc test_colour {} { set b1 [a red]1\n2\n3[a] set b2 [a green]a\nb\nc[a] @@ -8508,10 +8743,10 @@ interp alias {} piper_blockjoin {} ::textblock::piper::join # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide textblock [tcl::namespace::eval textblock { 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/textutil-0.9.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textutil-0.9.tm index 59258514..b18a5228 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textutil-0.9.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textutil-0.9.tm @@ -16,7 +16,7 @@ # ### ### ### ######### ######### ######### ## Requirements -package require Tcl 8.2 +package require Tcl 8.2- namespace eval ::textutil {} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textutil/wcswidth-35.2.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textutil/wcswidth-35.2.tm index a8afafeb..d153744a 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textutil/wcswidth-35.2.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/textutil/wcswidth-35.2.tm @@ -8,7 +8,7 @@ # Author: Sean Woods # Author: Andreas Kupries ### -package require Tcl 8.5 +package require Tcl 8.5- package provide textutil::wcswidth 35.2 namespace eval ::textutil {} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/tomlish-1.1.2.tm similarity index 87% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.1.tm rename to src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/tomlish-1.1.2.tm index 0c8d0b1a..c7da645b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.1.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/tomlish-1.1.2.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application tomlish 1.1.1 +# Application tomlish 1.1.2 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin tomlish_module_tomlish 0 1.1.1] +#[manpage_begin tomlish_module_tomlish 0 1.1.2] #[copyright "2024"] #[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] #[moddesc {tomlish}] [comment {-- Description at end of page heading --}] @@ -106,7 +106,7 @@ namespace eval tomlish { #TABLE is analogous to a Tcl dict #WS = inline whitespace #KEY = bare key and value - #QKEY = double quoted key and value + #QKEY = double quoted key and value ;#todo - rename to DQKEY? #SQKEY = single quoted key and value #ITABLE = inline table (*can* be anonymous table) # inline table values immediately create a table with the opening brace @@ -139,7 +139,7 @@ namespace eval tomlish { return $::tomlish::tags } - #helper function for get_dict + #helper function for to_dict proc _get_keyval_value {keyval_element} { log::notice ">>> _get_keyval_value from '$keyval_element'<<<" set found_value 0 @@ -147,7 +147,7 @@ namespace eval tomlish { # 3 is the earliest index at which the value could occur (depending on whitespace) set found_sub [list] if {[lindex $keyval_element 2] ne "="} { - error ">>>_get_keyval_value doesn't seem to be a properly structured { = } list" + error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured { = } list" } foreach sub [lrange $keyval_element 2 end] { #note that a barekey/quotedkey won't occur directly inside a barekey/quotedkey @@ -162,10 +162,10 @@ namespace eval tomlish { } } if {!$found_value} { - error "Failed to find value element in KEY. '$keyval_element'" + error "tomlish Failed to find value element in KEY. '$keyval_element'" } if {$found_value > 1} { - error "Found multiple value elements in KEY, expected exactly one. '$keyval_element'" + error "tomlish Found multiple value elements in KEY, expected exactly one. '$keyval_element'" } switch -exact -- $type { @@ -182,24 +182,26 @@ namespace eval tomlish { } TABLE { #invalid? - error "_get_keyval_value invalid to have type TABLE on rhs of =" + error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" } ITABLE { - set result [::tomlish::get_dict [list $found_sub]] + #This one should not be returned as a type value structure! + # + set result [::tomlish::to_dict [list $found_sub]] } ARRAY { #we need to recurse to get the corresponding dict for the contained item(s) #pass in the whole $found_sub - not just the $value! - set result [list type $type value [::tomlish::get_dict [list $found_sub]]] + set result [list type $type value [::tomlish::to_dict [list $found_sub]]] } MULTISTRING - MULTILITERAL { #review - mapping these to STRING might make some conversions harder? #if we keep the MULTI - we know we have to look for newlines for example when converting to json #without specific types we'd have to check every STRING - and lose info about how best to map chars within it - set result [list type $type value [::tomlish::get_dict [list $found_sub]]] + set result [list type $type value [::tomlish::to_dict [list $found_sub]]] } default { - error "Unexpected value type '$type' found in keyval '$keyval_element'" + error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" } } return $result @@ -209,7 +211,7 @@ namespace eval tomlish { set key_hierarchy [list] set key_hierarchy_raw [list] if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { - error "_get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" + error "tomlish _get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" } set compoundkeylist [lindex $dottedkeyrecord 1] set expect_sep 0 @@ -247,21 +249,37 @@ namespace eval tomlish { } return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] } - #get_dict is a *basic* programmatic datastructure for accessing the data. + + + + #to_dict is a *basic* programmatic datastructure for accessing the data. # produce a dictionary of keys and values from a tomlish tagged list. - # get_dict is primarily for reading toml data. + # to_dict is primarily for reading toml data. #Extraneous (not within quoted sections) whitespace and comments are not preserved in this structure, # so a roundtrip from toml to this datastructure and back to toml will lose whitespace formatting and comments. # creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. - proc get_dict {tomlish} { + # + #Note, currently we get a plain sub dictionary when an inline table is a direct value for a key, but an ITABLE when it's in an ARRAY - REVIEW + #Namespacing? + #ie note the difference: + #[Data] + #temp = { cpu = 79.5, case = 72.0} + # versus + #[Data] + #temps = [{cpu = 79.5, case = 72.0}] + proc to_dict {tomlish} { #keep track of which tablenames have already been directly defined, # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. #we don't error out just because a previous tablename segment has already appeared. - variable tablenames_seen [list] - + ##variable tablenames_seen [list] + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] + } log::info ">>> processing '$tomlish'<<<" set items $tomlish @@ -300,9 +318,9 @@ namespace eval tomlish { } DOTTEDKEY { log::debug "--> processing $tag: $item" - set dkey_info [_get_dottedkey_info $item] - set dotted_key_hierarchy [dict get $dkey_info keys] - set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] + set dkey_info [_get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] #a.b.c = 1 #table_key_hierarchy -> a b @@ -328,12 +346,15 @@ namespace eval tomlish { if {![dict exists $datastructure {*}$pathkeys]} { dict set datastructure {*}$pathkeys [list] } else { - tomlish::log::notice "get_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" + tomlish::log::notice "to_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" } } set keyval_dict [_get_keyval_value $item] dict set datastructure {*}$pathkeys $leafkey $keyval_dict + + #JMN test 2025 + } TABLE { set tablename [lindex $item 1] @@ -375,8 +396,40 @@ namespace eval tomlish { lappend table_key_hierarchy_raw $rawseg if {[dict exists $datastructure {*}$table_key_hierarchy]} { - #It's ok for this key to already exist *if* it was defined by a previous tablename, - # but not if it was defined as a key/qkey/skey ? + #It's ok for this key to already exist *if* it was defined by a previous tablename or equivalent + #and if this key is longer + + #consider the following 2 which are legal: + #[table] + #x.y = 3 + #[table.x.z] + #k= 22 + + #equivalent + + #[table] + #[table.x] + #y = 3 + #[table.x.z] + #k=22 + + #illegal + #[table] + #x.y = 3 + #[table.x.y.z] + #k = 22 + ## - we should bfail on encoungerint table.x.y because only table and table.x are effectively tables + ## - we should also fail if + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + + #TODO! fix - this code is wrong set testkey [join $table_key_hierarchy_raw .] @@ -411,7 +464,7 @@ namespace eval tomlish { if {$found_testkey == 0} { #the raw table_key_hierarchy is better to display in the error message, although it's not the actual dict keyset set msg "key [join $table_key_hierarchy_raw .] already exists in datastructure, but wasn't defined by a supertable." - append msg "tablenames_seen:" + append msg \n "tablenames_seen:" \n foreach ts $tablenames_seen { append msg " " $ts \n } @@ -428,7 +481,7 @@ namespace eval tomlish { if {![dict exists $datastructure {*}$table_keys]} { dict set datastructure {*}$table_keys [list] } else { - tomlish::log::notice "get_dict datastructure at (TABLE) subkey $table_keys already had data: [dict get $datastructure {*}$table_keys]" + tomlish::log::notice "to_dict datastructure at (TABLE) subkey $table_keys already had data: [dict get $datastructure {*}$table_keys]" } } @@ -442,13 +495,18 @@ namespace eval tomlish { #now add the contained elements foreach element [lrange $item 2 end] { set type [lindex $element 0] + log::debug "--> $type processing contained element $element" switch -exact -- $type { DOTTEDKEY { set dkey_info [_get_dottedkey_info $element] - set dotted_key_hierarchy [dict get $dkey_info keys] - set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] - set leaf_key [lindex $dotted_key_hierarchy end] - set dkeys [lrange $dotted_key_hierarchy 0 end-1] + #e.g1 keys {x.y y} keys_raw {'x.y' y} + #e.g2 keys {x.y y} keys_raw {{"x.y"} y} + set dotted_key_hierarchy [dict get $dkey_info keys] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + set leaf_key [lindex $dotted_key_hierarchy end] + set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] + set dkeys_raw [lrange $dotted_key_hierarchy_raw 0 end-1] + set leaf_key_raw [lindex $dotted_key_hierarchy_raw end] #ensure empty keys are still represented in the datastructure set test_keys $table_keys @@ -457,7 +515,7 @@ namespace eval tomlish { if {![dict exists $datastructure {*}$test_keys]} { dict set datastructure {*}$test_keys [list] } else { - tomlish::log::notice "get_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" } } @@ -465,7 +523,22 @@ namespace eval tomlish { error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." } set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout ">>> $keyval_dict" dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + #JMN 2025 + #tomlish::utils::normalize_key ?? + lappend tablenames_seen [join [list {*}$table_key_hierarchy_raw {*}$dkeys_raw] .] ;#???? + #if the keyval_dict is not a simple type x value y - then it's an inline table ? + #if so - we should add the path to the leaf_key as a seen table too - as it's not allowed to have more entries added. + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + lappend tablenames_seen [join [list {*}$table_key_hierarchy_raw {*}$dkeys_raw $leaf_key_raw] .] + } + } KEY - QKEY - SQKEY { #obsolete ? @@ -511,7 +584,7 @@ namespace eval tomlish { if {![dict exists $datastructure {*}$test_keys]} { dict set datastructure {*}$test_keys [list] } else { - tomlish::log::notice "get_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" } } @@ -552,7 +625,7 @@ namespace eval tomlish { } ITABLE - TABLE - ARRAY - MULTISTRING - MULTILITERAL { set value [lindex $element 1] - lappend datastructure [list type $type value [::tomlish::get_dict [list $element]]] + lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] } WS - SEP - NEWLINE - COMMENT { #ignore whitespace, commas, newlines and comments @@ -620,7 +693,7 @@ namespace eval tomlish { STRING { #todo - do away with STRING ? #we don't build MULTISTRINGS containing STRING - but should we accept it? - tomlish::log::warn "doulbe quoting a STRING found in MULTISTRING - should be STRINGPART?" + tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" } STRINGPART { @@ -707,6 +780,299 @@ namespace eval tomlish { return $datastructure } + + proc _from_dictval_tomltype {parents tablestack keys typeval} { + set type [dict get $typeval type] + set val [dict get $typeval value] + switch -- $type { + ARRAY { + set subitems [list] + foreach item $val { + lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP + } + if {[lindex $subitems end] eq "SEP"} { + set subitems [lrange $subitems 0 end-1] + } + return [list ARRAY {*}$subitems] + } + ITABLE { + if {$val eq ""} { + return ITABLE + } else { + return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] + } + } + MULTISTRING { + #value is a raw string that isn't encoded as tomlish + #create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format + set tomlpart "x=\"\"\"\\\n" + append tomlpart $val "\"\"\"" + set tomlish [tomlish::decode::toml $tomlpart] + #e.g if val = " etc\nblah" + #TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } + #lindex 1 3 is the MULTISTRING tomlish list + return [lindex $tomlish 1 3] + } + MULTILITERAL { + set tomlpart "x='''\n" + append tomlpart $val ''' + set tomlish [tomlish::decode::toml $tomlpart] + return [lindex $tomlish 1 3] + } + default { + return [list $type $val] + } + } + } + + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + if {[regexp {\s} $k] || [string first . $k] >= 0} { + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + #todo - QKEY? + set K_PART [list SQKEY $k] + } else { + set K_PART [list KEY $k] + } + puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" + puts stderr "---tablestack: $tablestack---" + set result [list] + set lastparent [lindex $parents end] + if {$lastparent in [list "" do_inline]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + set type [dict get $vinfo type] + #treat ITABLE differently? + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} + } else { + #set result [list TABLE $k {NEWLINE lf}] + if {$vinfo ne ""} { + + #set result [list DOTTEDKEY [list [list KEY $k]] = ] + #set records [list ITABLE] + + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + + if {$lastparent eq "do_inline"} { + set result [list DOTTEDKEY [list $K_PART] =] + set records [list ITABLE] + } else { + #review - quoted k ?? + set result [list TABLE $k {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $k]] + set records [list] + } + + + + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + dict for {vk vv} $vinfo { + if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + set VK_PART [list SQKEY $vk] + } else { + set VK_PART [list KEY $vk] + } + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] + } else { + if {$vv eq ""} { + #experimental + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" + #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] + set tname [join [list {*}$keys $vk] .] + set record [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + } else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + } + } else { + if { 0 } { + #experiment.. sort of getting there. + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" + set tname [join [list {*}$keys $vk] .] + set record [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + + #review - todo? + set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] + lappend record {*}$dottedkey_value + + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + } + if {$dictidx != $lastidx} { + #lappend record SEP + if {$lastparent eq "do_inline"} { + lappend record SEP + } else { + lappend record {NEWLINE lf} + } + } + lappend records $record + incr dictidx + } + if {$lastparent eq "do_inline"} { + lappend result $records {NEWLINE lf} + } else { + lappend result {*}$records {NEWLINE lf} + } + } else { + if {$lastparent eq "do_inline"} { + lappend result DOTTEDKEY [list [list KEY $k]] = ITABLE {NEWLINE lf} + } else { + lappend result TABLE $k {NEWLINE lf} + } + } + } + } else { + #lastparent is not toplevel "" or "do_inline" + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result {*}$sublist + } else { + if {$lastparent eq "TABLE"} { + #review + dict for {vk vv} $vinfo { + set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] + lappend result [list DOTTEDKEY [list [list KEY $vk]] = $dottedkey_value {NEWLINE lf}] + } + } else { + if {$vinfo ne ""} { + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + set sub [list] + set result $lastparent ;#e.g sets ITABLE + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + dict for {vk vv} $vinfo { + if {[regexp {\s} $vk] || [string first . $vk] >=0} { + set VK_PART [list SQKEY $vk] + } else { + set VK_PART [list KEY $vk] + } + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART] = $sublist] + } else { + if {$vv eq ""} { + #can't just uninline at this level + #we need a better method to query main dict for uninlinability at each level + # (including what's been inlined already) + #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + # puts stderr "_from_dictval uninline2 KEY $keys" + # set tname [join [list {*}$keys $vk] .] + # set record [list TABLE $tname {NEWLINE lf}] + # set tablestack [list {*}$tablestack [list T $vk]] + #} else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + #} + } else { + #set sub [_from_dictval ITABLE $vk $vv] + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + #set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + if {$dictidx != $lastidx} { + lappend record SEP + } + lappend result $record + incr dictidx + } + } else { + puts stderr "table x-1" + lappend result DOTTEDKEY [list $K_PART] = ITABLE + } + } + } + } + return $result + } + + + proc from_dict {d} { + #consider: + # t1={a=1,b=2} + # x = 1 + #If we represent t1 as an expanded table we get + # [t1] + # a=1 + # b=2 + # x=1 + # --- which is incorrect - as x was a toplevel key like t1! + #This issue doesn't occur if x is itself an inline table + # t1={a=1,b=2} + # x= {no="problem"} + # + # (or if we were to reorder x to come before t1) + + #As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} + #Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, + #which is unpreferred here. + + #A possible solution: + #scan the top level to see if all (trailing) elements are themselves dicts + # (ie not of form {type XXX value yyy}) + # + # A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements + #ie we don't need to force do_inline if all the 'simple' keys are before any compound keys + + #set root_has_values 0 + #approach 1) - the naive approach - forces inline when not always necessary + #dict for {k v} $d { + # if {[llength $v] == 4 && [lindex $v 0] eq "type"} { + # set root_has_values 1 + # break + # } + #} + + + #approach 2) - track the position of last {type x value y} in the dictionary built by to_dict + # - still not perfect. Inlines dotted tables unnecessarily + #This means from_dict doesn't produce output optimal for human editing. + set last_simple [tomlish::dict::last_tomltype_posn $d] + + + ## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values + #Any keys that are themselves tables - will need to be represented inline + #to avoid reordering, or incorrect assignment of plain values to the wrong table. + + ## set parent "" + #all toplevel keys in the dict structure can represent subtables. + #we are free to use {[tablename]\n} syntax for toplevel elements. + + + set tomlish [list TOMLISH] + set dictposn 0 + set tablestack [list [list T root]] ;#todo + dict for {t tinfo} $d { + if {$last_simple > $dictposn} { + set parents [list do_inline] + } else { + set parents [list ""] + } + set keys [list $t] + set trecord [_from_dictval $parents $tablestack $keys $tinfo] + lappend tomlish $trecord + incr dictposn + } + return $tomlish + } + proc json_to_toml {json} { #*** !doctools #[call [fun json_to_toml] [arg json]] @@ -734,7 +1100,7 @@ namespace eval tomlish { proc get_json {tomlish} { package require fish::json - set d [::tomlish::get_dict $tomlish] + set d [::tomlish::to_dict $tomlish] #return [::tomlish::dict_to_json $d] return [fish::json::from "struct" $d] } @@ -1067,7 +1433,10 @@ namespace eval tomlish::decode { #i.e get a standard list of all the toml terms in string $s #where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. #(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) - #Note that we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- + # NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! + # e.g we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- #Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. # (e.g perhaps a toml editor to highlight violations for fixing) # A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. @@ -2097,7 +2466,8 @@ namespace eval tomlish::utils { } ;#RS #check if str is valid for use as a toml bare key - proc is_barekey {str} { + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { if {[tcl::string::length $str] == 0} { return 0 } else { @@ -2111,6 +2481,52 @@ namespace eval tomlish::utils { } } + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + #test only that the characters in str are valid for the toml specified type 'integer'. proc int_validchars1 {str} { set numchars [tcl::string::length $str] @@ -3023,7 +3439,7 @@ namespace eval tomlish::parse { # - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. proc set_token_waiting {args} { if {[llength $args] %2 != 0} { - error "set_token_waiting must have args of form: type value complete 0|1" + error "tomlish set_token_waiting must have args of form: type value complete 0|1" } variable token_waiting @@ -3031,7 +3447,7 @@ namespace eval tomlish::parse { #tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another #we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it - set err "set_token_waiting already has token_waiting: [lindex $token_waiting 0]" + set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" append err \n " - cannot add token_waiting: $args" error $err #set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] @@ -3051,19 +3467,19 @@ namespace eval tomlish::parse { dict set waiting startindex $v } default { - error "set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" + error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" } } } if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { - error "set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" + error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" } if {![llength $token_waiting]} { set token_waiting [list $waiting] } else { #an extra sanity-check that we don't have more than just the eof.. if {[llength $token_waiting] > 1} { - set err "Unexpected. Existing token_waiting count > 1.\n" + set err "tomlish Unexpected. Existing token_waiting count > 1.\n" foreach tw $token_waiting { append err " $tw" \n } @@ -3164,7 +3580,7 @@ namespace eval tomlish::parse { return 1 } barekey { - error "Unexpected character '$c' during bare key. Only \[a-zA-Z_-\] allowed. [tomlish::parse::report_line]" + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" } whitespace { # hash marks end of whitespace token @@ -3181,7 +3597,7 @@ namespace eval tomlish::parse { } starttablename - starttablearrayname { #fix! - error "Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" + error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" } tablename - tablearrayname { #invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out @@ -3248,7 +3664,7 @@ namespace eval tomlish::parse { } starttablename - starttablearrayname { #*bare* tablename can only contain letters,digits underscores - error "Invalid tablename first character \{ [tomlish::parse::report_line]" + error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" } tablename - tablearrayname { #valid in quoted parts @@ -3297,7 +3713,7 @@ namespace eval tomlish::parse { set tok "\{" } default { - error "state: '$state'. left brace case not implemented [tomlish::parse::report_line]" + error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" } } } @@ -3349,7 +3765,7 @@ namespace eval tomlish::parse { } itable-val-tail { #review - error "right-curly in itable-val-tail" + error "tomlish right-curly in itable-val-tail" } default { #end any other token @@ -3387,7 +3803,7 @@ namespace eval tomlish::parse { return 1 } tablearrayname-state { - error "unexpected tablearrayname-state problem" + error "tomlish unexpected tablearrayname-state problem" set_tokenType "endinlinetable" set tok "" ;#no output into the tomlish list for this token return 1 @@ -3411,7 +3827,7 @@ namespace eval tomlish::parse { return 1 } itable-keyval-syntax { - error "endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" + error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" } multistring-space { set_tokenType "stringpart" @@ -3427,7 +3843,7 @@ namespace eval tomlish::parse { } default { #JMN2024b keyval-tail? - error "state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" + error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" } } } @@ -3533,8 +3949,12 @@ namespace eval tomlish::parse { set_tokenType "literalpart" set tok "\[" } + itable-space { + #handle state just to give specific error msg + error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[\] syntax. [tomlish::parse::report_line]" + } default { - error "state: '$state'. startarray case not implemented [tomlish::parse::report_line]" + error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" } } } @@ -3639,7 +4059,7 @@ namespace eval tomlish::parse { return 1 } tablearrayname-state { - error "unexpected tablearrayname problem" + error "tomlish unexpected tablearrayname problem" set_tokenType "endtablearray" set tok "" ;#no output into the tomlish list for this token return 1 @@ -3662,7 +4082,7 @@ namespace eval tomlish::parse { set tok "\]" } default { - error "state '$state'. endarray case not implemented [tomlish::parse::report_line]" + error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" } } } @@ -3691,7 +4111,7 @@ namespace eval tomlish::parse { incr i -1 ;#reprocess bsl in next run return 1 } else { - error "Unexpected backslash during whitespace. [tomlish::parse::report_line]" + error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" } } literal - literalpart - squotedkey - itablesquotedkey { @@ -3718,7 +4138,7 @@ namespace eval tomlish::parse { } } starttablename - starttablearrayname { - error "backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" + error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" } tablename - tablearrayname { if {$slash_active} { @@ -3729,10 +4149,10 @@ namespace eval tomlish::parse { } } barekey { - error "Unexpected backslash during barekey. [tomlish::parse::report_line]" + error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" } default { - error "Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" + error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" } } } else { @@ -3756,7 +4176,7 @@ namespace eval tomlish::parse { set tok "\\" } default { - error "tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" + error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" } } } @@ -3776,7 +4196,7 @@ namespace eval tomlish::parse { leading-squote-space { append tok $c if {$existingtoklen > 2} { - error "tok error: squote_seq unexpected length $existingtoklen when another received" + error "tomlish tok error: squote_seq unexpected length $existingtoklen when another received" } elseif {$existingtoklen == 2} { return 1 ;#return tok ''' } @@ -3790,7 +4210,7 @@ namespace eval tomlish::parse { } } default { - error "tok error: squote_seq in unexpected state '$state' - expected leading-squote-space or trailing-squote-space" + error "tomlish tok error: squote_seq in unexpected state '$state' - expected leading-squote-space or trailing-squote-space" } } } @@ -3815,7 +4235,7 @@ namespace eval tomlish::parse { return 1 } default { - error "unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" } } } @@ -3892,7 +4312,7 @@ namespace eval tomlish::parse { return 1 } multistring-space { - error "unimplemented - squote during state '$state'. [tomlish::parse::report_line]" + error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" } multiliteral-space { #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row @@ -3908,7 +4328,7 @@ namespace eval tomlish::parse { set_tokenType squotedkey } default { - error "unhandled squote during state '$state'. [tomlish::parse::report_line]" + error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" } } } @@ -3935,7 +4355,7 @@ namespace eval tomlish::parse { set_tokenType "startmultiquote" return 1 } else { - error "unexpected token length $toklen in 'startquotesequence'" + error "tomlish unexpected token length $toklen in 'startquotesequence'" } } _start_squote_sequence { @@ -3952,7 +4372,7 @@ namespace eval tomlish::parse { return 1 } default { - error "unexpected _start_squote_sequence length $toklen" + error "tomlish unexpected _start_squote_sequence length $toklen" } } } @@ -4055,7 +4475,7 @@ namespace eval tomlish::parse { return 1 } default { - error "got quote during tokenType '$tokenType' [tomlish::parse::report_line]" + error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" } } } else { @@ -4070,6 +4490,11 @@ namespace eval tomlish::parse { set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote set tok $c } + itable-keyval-value-expected { + #JMN 2025 - review + set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote + set tok $c + } multistring-space { #TODO - had_slash!!! #REVIEW @@ -4118,7 +4543,7 @@ namespace eval tomlish::parse { set tok $c } default { - error "Unexpected quote during state '$state' [tomlish::parse::report_line]" + error "tomlish Unexpected quote during state '$state' [tomlish::parse::report_line]" } } } @@ -4172,14 +4597,14 @@ namespace eval tomlish::parse { return 1 } starttablename - starttablearrayname { - error "Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" + error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" } tablename - tablearrayname { #invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out append tok $c } default { - error "unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" + error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" } } } else { @@ -4234,17 +4659,22 @@ namespace eval tomlish::parse { append tok $c } literalpart { + #part of MLL string (multi-line literal string) #we need to split out crlf as a separate NEWLINE to be consistent - ::tomlish::log::warning "literalpart ended by cr - needs testing" + ::tomlish::log::warn "literalpart ended by cr - needs testing" #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space incr i -1 return 1 } stringpart { - append tok $dquotes$c + #part of MLB string (multi-line basic string) + #jmn2025 - review + #append tok $dquotes$c + incr i -1 + return 1 } starttablename - starttablearrayname { - error "Character is invalid first character for $tokenType. [tomlish::parse::report_line]" + error "tomlish Character is invalid first character for $tokenType. [tomlish::parse::report_line]" } tablename - tablearrayname { #could in theory be valid in quoted part of name @@ -4319,7 +4749,7 @@ namespace eval tomlish::parse { } } starttablename - tablename - tablearrayname - starttablearrayname { - error "Character is invalid in $tokenType. [tomlish::parse::report_line]" + error "tomlish Character is invalid in $tokenType. [tomlish::parse::report_line]" } default { #newline ends all other tokens. @@ -4515,13 +4945,13 @@ namespace eval tomlish::parse { return 1 } default { - error "Received period during tokenType 'whitespace' [tomlish::parse::report_line]" + error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" } } } starttablename - starttablearrayname { #This would correspond to an empty table name - error "Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" + error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" } tablename - tablearrayname { #subtable - split later - review @@ -4535,7 +4965,7 @@ namespace eval tomlish::parse { return 1 } default { - error "Received period during tokenType '$tokenType' [tomlish::parse::report_line]" + error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" #set_token_waiting type period value . complete 1 #return 1 } @@ -4656,7 +5086,7 @@ namespace eval tomlish::parse { append tok $c } default { - error "Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" + error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" } } } else { @@ -4700,7 +5130,7 @@ namespace eval tomlish::parse { } default { if {$had_slash} { - error "unexpected backslash [tomlish::parse::report_line]" + error "tomlish unexpected backslash [tomlish::parse::report_line]" } set_tokenType "whitespace" append tok $c @@ -4775,7 +5205,7 @@ namespace eval tomlish::parse { append tok $c } default { - error "Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" + error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" } } } else { @@ -4901,7 +5331,7 @@ namespace eval tomlish::parse { if {[tomlish::utils::is_barekey $c]} { append tok $c } else { - error "Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] allowed. [tomlish::parse::report_line]" + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" } } starttablename - starttablearrayname { @@ -4927,7 +5357,7 @@ namespace eval tomlish::parse { set_tokenType "barekey" append tok $c } else { - error "Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" } } curly-syntax { @@ -4936,7 +5366,7 @@ namespace eval tomlish::parse { set_tokenType "barekey" append tok $c } else { - error "Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" } } multistring-space { @@ -4988,7 +5418,7 @@ namespace eval tomlish::parse { if {$toklen == 1} { #invalid #eof with open string - error "eof reached without closing quote for string. [tomlish::parse::report_line]" + error "tomlish eof reached without closing quote for string. [tomlish::parse::report_line]" } elseif {$toklen == 2} { #valid #we ended in a double quote, not actually a startquoteseqence - effectively an empty string @@ -5003,7 +5433,7 @@ namespace eval tomlish::parse { switch -- $toklen { 1 { #invalid eof with open literal - error "eof reached without closing single quote for string literal. [tomlish::parse::report_line]" + error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" } 2 { #review @@ -5029,6 +5459,68 @@ namespace eval tomlish::parse { #[list_end] [comment {--- end definitions namespace tomlish::parse ---}] } +namespace eval tomlish::dict { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} + } + proc is_tomlish_typeval2 {d} { + upvar ::tomlish::tags tags + expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} + } + proc last_tomltype_posn {d} { + set last_simple -1 + set dictposn [expr {[dict size $d] -1}] + foreach k [lreverse [dict keys $d]] { + set dval [dict get $d $k] + if {[is_tomlish_typeval $dval]} { + set last_simple $dictposn + break + } + incr dictposn -1 + } + return $last_simple + } + + + #review + proc name_from_tablestack {tablestack} { + set name "" + foreach tinfo [lrange $tablestack 1 end] { + lassign $tinfo type namepart + switch -- $type { + T { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + I { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + default { + #end at first break in the leading sequence of T & I tablenames + break + } + } + } + return $name + } + +} + tcl::namespace::eval tomlish::app { variable applist [list encoder decoder test] @@ -5179,7 +5671,7 @@ if {$argc > 0} { package provide tomlish [namespace eval tomlish { variable pkg tomlish variable version - set version 1.1.1 + set version 1.1.2 }] return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/tomlish-1.1.3.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/tomlish-1.1.3.tm new file mode 100644 index 00000000..3da39427 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/tomlish-1.1.3.tm @@ -0,0 +1,6002 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application tomlish 1.1.3 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin tomlish_module_tomlish 0 1.1.3] +#[copyright "2024"] +#[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] +#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] +#[require tomlish] +#[keywords module parsing toml configuration] +#[description] +#[para] tomlish is an intermediate representation of toml data in a tree structure (tagged lists representing type information) +#[para] The design goals are for tomlish to be whitespace and comment preserving ie byte-for byte preservation during roundtrips from toml to tomlish and back to toml +#[para] The tomlish representation can then be converted to a Tcl dict structure or to other formats such as json, +#[para] although these other formats are generally unlikely to retain whitespace or comments +#[para] The other formats also won't preserve roundtripability e.g \t and a literal tab coming from a toml file will be indistinguishable. +#[para] A further goal is to allow at least a useful subset of in-place editing operations which also preserve whitespace and comments. +#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions +#[para] The API for editing (tomldoc object?) may require explicit setting of type if accessing an existing key +#[para] e.g setting a key that already exists and is a different type (especially if nested structure such as a table or array) +#[para] will need a -type option (-force ?) to force overriding with another type such as an int. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of tomlish +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by tomlish +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::stack +package require logger + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {struct::stack}] + +#limit ourselves to clear, destroy, peek, pop, push, rotate, or size (e.g v 1.3 does not implement 'get') + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish { + namespace export {[a-z]*}; # Convention: export all lowercase + variable types + + #IDEAS: + # since get_toml produces tomlish with whitespace/comments intact: + # tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace + # - setKey (set leaf only to value) how to specify type? -type option? - whole array vs index into arrays and further nested objects? - option for raw toml additions? + # - separate addKey?? + # - deleteKey (delete leaf) + # - deleteTable (delete table - if only has leaves? - option to delete with child tables?) + # - set/add Table? - position in doc based on existing tables/subtables? + + #The tomlish intermediate representation allows things such as sorting the toml document by table name or other re-ordering of tables - + # because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. + #The same goes for the first newline following a keyval e.g x=1 \ny=2\n\n + #The newline is part of the keyval structure so makes reordering easier + #example from_toml "a=1\nb=2\n\n\n" + # 0 = TOMLISH + # 1 = KEY a = {INT 1} {NEWLINE lf} + # 2 = NEWLINE lf + # 3 = KEY b = {INT 2} {NEWLINE lf} + # 4 = NEWLINE lf + # 5 = NEWLINE lf + + + #ARRAY is analogous to a Tcl list + #TABLE is analogous to a Tcl dict + #WS = inline whitespace + #KEY = bare key and value + #DQKEY = double quoted key and value + #SQKEY = single quoted key and value + #ITABLE = inline table (*can* be anonymous table) + # inline table values immediately create a table with the opening brace + # inline tables are fully defined between their braces, as are dotted-key subtables defined within + # No additional subtables or arrays of tables may be defined within an inline table after the ending brace - they must be entirely self-contained + + set tags [list TOMLISH ARRAY TABLE ITABLE ANONTABLE WS NEWLINE COMMENT DOTTEDKEY KEY DQKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME] + #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) + #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) + set min_int -9223372036854775808 ;#-2^63 + set max_int +9223372036854775807 ;#2^63-1 + + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] tomlish '$txt'" + puts stderr $msg + } + logger::initNamespace ::tomlish + foreach lvl [logger::levels] { + interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl + log::logproc $lvl tomlish_log_$lvl + } + + #*** !doctools + #[subsection {Namespace tomlish}] + #[para] Core API functions for tomlish + #[list_begin definitions] + + proc tags {} { + return $::tomlish::tags + } + + #helper function for to_dict + proc _get_keyval_value {keyval_element} { + log::notice ">>> _get_keyval_value from '$keyval_element'<<<" + set found_value 0 + #find the value + # 3 is the earliest index at which the value could occur (depending on whitespace) + set found_sub [list] + if {[lindex $keyval_element 2] ne "="} { + error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured { = } list" + } + + #review + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] ;#list of lists + } + if {[uplevel 1 [list info exists tablenames_closed]]} { + upvar tablenames_closed tablenames_closed + } else { + set tablenames_closed [list] ;#list of lists + } + + foreach sub [lrange $keyval_element 2 end] { + #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey + switch -exact -- [lindex $sub 0] { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - TABLE - ARRAY - ITABLE { + set type [lindex $sub 0] + set value [lindex $sub 1] + set found_sub $sub + incr found_value 1 + } + default {} + } + } + if {!$found_value} { + error "tomlish Failed to find value element in KEY. '$keyval_element'" + } + if {$found_value > 1} { + error "tomlish Found multiple value elements in KEY, expected exactly one. '$keyval_element'" + } + + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + #simple (non-container, no-substitution) datatype + set result [list type $type value $value] + } + STRING - STRINGPART { + set result [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL - LITERALPART { + #REVIEW + set result [list type $type value $value] + } + TABLE { + #invalid? + error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" + } + ITABLE { + #This one should not be returned as a type value structure! + # + set result [::tomlish::to_dict [list $found_sub]] + } + ARRAY { + #we need to recurse to get the corresponding dict for the contained item(s) + #pass in the whole $found_sub - not just the $value! + set prev_tablenames_seen $tablenames_seen + set prev_tablenames_closed $tablenames_closed + set tablenames_seen [list] + set tablenames_closed [list] + set result [list type $type value [::tomlish::to_dict [list $found_sub]]] + set tablenames_seen $prev_tablenames_seen + set tablenames_closed $prev_tablenames_closed + } + MULTISTRING - MULTILITERAL { + #review - mapping these to STRING might make some conversions harder? + #if we keep the MULTI - we know we have to look for newlines for example when converting to json + #without specific types we'd have to check every STRING - and lose info about how best to map chars within it + set result [list type $type value [::tomlish::to_dict [list $found_sub]]] + } + default { + error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" + } + } + return $result + } + + proc _get_dottedkey_info {dottedkeyrecord} { + set key_hierarchy [list] + set key_hierarchy_raw [list] + if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { + error "tomlish _get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" + } + set compoundkeylist [lindex $dottedkeyrecord 1] + set expect_sep 0 + foreach part $compoundkeylist { + set parttag [lindex $part 0] + if {$parttag eq "WS"} { + continue + } + if {$expect_sep} { + if {$parttag ne "DOTSEP"} { + error "DOTTEDKEY missing dot separator between parts. '$dottedkeyrecord'" + } + set expect_sep 0 + } else { + set val [lindex $part 1] + switch -exact -- $parttag { + KEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw $val + } + DQKEY { + lappend key_hierarchy [::tomlish::utils::unescape_string $val] + lappend key_hierarchy_raw \"$val\" + } + SQKEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw "'$val'" + } + default { + error "DOTTED key unexpected part '$parttag' - ensure dot separator is between key parts. '$item'" + } + } + set expect_sep 1 + } + } + return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] + } + + + + #to_dict is a *basic* programmatic datastructure for accessing the data. + # produce a dictionary of keys and values from a tomlish tagged list. + # to_dict is primarily for reading toml data. + #Extraneous (not within quoted sections) whitespace and comments are not preserved in this structure, + # so a roundtrip from toml to this datastructure and back to toml will lose whitespace formatting and comments. + # creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. + #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. + # + + #within an ARRAY, we store a list of items such as plain dicts (possibly empty) and {type value } for simple types + #(ARRAYS can be mixed type) + #This means our dict structure should have only ARRAY and simple types which need to be in {type value } form + #A dict within an array encodeded as a type ITABLE value should also parse - but is the unpreferred form - REVIEW test? + + #Namespacing? + #ie note the difference: + #[Data] + #temp = { cpu = 79.5, case = 72.0} + # versus + #[Data] + #temps = [{cpu = 79.5, case = 72.0}] + proc to_dict {tomlish} { + + #keep track of which tablenames have already been directly defined, + # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' + #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. + #we don't error out just because a previous tablename segment has already appeared. + ##variable tablenames_seen [list] + if {[uplevel 1 [list info exists tablenames_seen]]} { + upvar tablenames_seen tablenames_seen + } else { + set tablenames_seen [list] ;#list of lists + } + if {[uplevel 1 [list info exists tablenames_closed]]} { + upvar tablenames_closed tablenames_closed + } else { + set tablenames_closed [list] ;#list of lists + } + + log::info "---> to_dict processing '$tomlish'<<<" + set items $tomlish + + foreach lst $items { + if {[lindex $lst 0] ni $::tomlish::tags} { + error "supplied string does not appear to be toml parsed into a tomlish tagged list. Run tomlish::decode::toml on the raw toml data to produce a tomlish list" + } + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + #ignore TOMLISH tag at beginning + set items [lrange $tomlish 1 end] + } + + set datastructure [dict create] + foreach item $items { + set tag [lindex $item 0] + #puts "...> item:'$item' tag:'$tag'" + switch -exact -- $tag { + KEY - DQKEY - SQKEY { + log::debug "---> to_dict item: processing $tag: $item" + set key [lindex $item 1] + if {$tag eq "DQKEY"} { + set key [::tomlish::utils::unescape_string $key] + } + #!todo - normalize key. (may be quoted/doublequoted) + + if {[dict exists $datastructure $key]} { + error "Duplicate key '$key'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #lassign [_get_keyval_value $item] type val + set keyval_dict [_get_keyval_value $item] + dict set datastructure $key $keyval_dict + } + DOTTEDKEY { + log::debug "---> to_dict item processing $tag: $item" + set dkey_info [_get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + + #a.b.c = 1 + #table_key_hierarchy -> a b + #leafkey -> c + if {[llength $dotted_key_hierarchy] == 0} { + #empty?? probably invalid. review + #This is different to '' = 1 or ''.'' = 1 which have lengths 1 and 2 respectively + error "DOTTED key has no parts - invalid? '$item'" + } elseif {[llength $dotted_key_hierarchy] == 1} { + #dottedkey is only a key - no table component + set table_hierarchy [list] + set leafkey [lindex $dotted_key_hierarchy 0] + } else { + set table_hierarchy [lrange $dotted_key_hierarchy 0 end-1] + set leafkey [lindex $dotted_key_hierarchy end] + } + + #ensure empty tables are still represented in the datastructure + #review - this seems unnecessary? + set pathkeys [list] + foreach k $table_hierarchy { + lappend pathkeys $k + if {![dict exists $datastructure {*}$pathkeys]} { + dict set datastructure {*}$pathkeys [list] + } else { + tomlish::log::notice "to_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" + } + } + #review? + if {[dict exists $datastructure {*}$table_hierarchy $leafkey]} { + error "Duplicate key '$table_hierarchy $leafkey'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #JMN test 2025 + if {[llength $table_hierarchy]} { + lappend tablenames_seen $table_hierarchy + } + + set keyval_dict [_get_keyval_value $item] + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + lappend tablenames_seen [list {*}$table_hierarchy $leafkey] + lappend tablenames_closed [list {*}$table_hierarchy $leafkey] + + #review - item is an ITABLE - we recurse here without datastructure context :/ + #overwriting keys? todo ? + dict set datastructure {*}$table_hierarchy $leafkey $keyval_dict + } else { + dict set datastructure {*}$table_hierarchy $leafkey $keyval_dict + } + + } + TABLE { + set tablename [lindex $item 1] + #set tablename [::tomlish::utils::tablename_trim $tablename] + set norm_segments [::tomlish::utils::tablename_split $tablename true] ;#true to normalize + if {$norm_segments in $tablenames_seen} { + error "Table name '$tablename' has already been directly defined in the toml data. Invalid." + } + + log::debug "---> to_dict processing item $tag (name: $tablename): $item" + set name_segments [::tomlish::utils::tablename_split $tablename] ;#unnormalized + set last_seg "" + #toml spec rule - all segments mst be non-empty + #note that the results of tablename_split are 'raw' - ie some segments may be enclosed in single or double quotes. + + set table_key_sublist [list] + + foreach normseg $norm_segments { + lappend table_key_sublist $normseg + if {[dict exists $datastructure {*}$table_key_sublist]} { + #It's ok for this key to already exist *if* it was defined by a previous tablename or equivalent + #and if this key is longer + + #consider the following 2 which are legal: + #[table] + #x.y = 3 + #[table.x.z] + #k= 22 + + #equivalent + + #[table] + #[table.x] + #y = 3 + #[table.x.z] + #k=22 + + #illegal + #[table] + #x.y = 3 + #[table.x.y.z] + #k = 22 + ## - we should fail on encountering table.x.y because only table and table.x are effectively tables + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + + #note: it is not safe to compare normalized tablenames using join! + # e.g a.'b.c'.d is not the same as a.b.c.d + # instead compare {a b.c d} with {a b c d} + # Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. + #'a.b'.'c.d.e' vs 'a.b.c'.'d.e' + #we need to normalize the tablenames seen so that {"x\ty"} matches {"xy"} + + set sublist_length [llength $table_key_sublist] + set found_testkey 0 + if {$table_key_sublist in $tablenames_seen} { + set found_testkey 1 + } else { + #see if it was defined by a longer entry + foreach seen_table_segments $tablenames_seen { + if {[llength $seen_table_segments] <= $sublist_length} { + continue + } + #each tablenames_seen entry is already a list of normalized segments + + #we could have [a.b.c.d] early on + # followed by [a.b] - which was still defined by the earlier one. + + set seen_longer [lrange $seen_segments 0 [expr {$sublist_length -1}]] + puts stderr "testkey:'$table_key_sublist' vs seen_match:'$seen_longer'" + if {$table_key_sublist eq $seen_longer} { + set found_testkey 1 + } + } + } + + if {$found_testkey == 0} { + #the raw table_key_hierarchy is better to display in the error message, although it's not the actual dict keyset + set msg "key $table_key_sublist already exists in datastructure, but wasn't defined by a supertable." + append msg \n "tablenames_seen:" \n + foreach ts $tablenames_seen { + append msg " " $ts \n + } + error $msg + } + } + + } + + #ensure empty tables are still represented in the datastructure + set table_keys [list] + foreach k $table_key_hierarchy { + lappend table_keys $k + if {![dict exists $datastructure {*}$table_keys]} { + dict set datastructure {*}$table_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (TABLE) subkey $table_keys already had data: [dict get $datastructure {*}$table_keys]" + } + } + + #We must do this after the key-collision test above! + lappend tablenames_seen $norm_segments + + + log::debug ">>> to_dict >>>>>>>>>>>>>>>>> table_key_hierarchy : $table_key_hierarchy" + + #now add the contained elements + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [_get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + set dotted_key_hierarchy [dict get $dkey_info keys] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + set leaf_key [lindex $dotted_key_hierarchy end] + + #ensure empty keys are still represented in the datastructure + set test_keys $table_keys + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { + error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> $keyval_dict" + dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + #JMN 2025 + lappend tablenames_seen [list {*}$table_key_hierarchy {*}$dkeys] + + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + lappend tablenames_seen [list {*}$table_key_hierarchy {*}$dkeys $leaf_key] + #if the keyval_dict is not a simple type x value y - then it's an inline table ? + #if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + } + + } + KEY - DQKEY - SQKEY { + #obsolete ? + set keyval_key [lindex $element 1] + if {$type eq "DQKEY"} { + set keyval_key [::tomlish::utils::unescape_string $keyval_key] + } + if {[dict exists $datastructure {*}$dotted_key_hierarchy $keyval_key]} { + error "Duplicate key '$dotted_key_hierarchy $key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + dict set datastructure {*}$dotted_key_hierarchy $keyval_key $keyval_dict + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in table context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + #now make sure we add an empty value if there were no contained elements! + #!todo. + } + ITABLE { + #SEP??? + set datastructure [list] + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [_get_dottedkey_info $element] + set dotted_key_hierarchy [dict get $dkey_info keys] + set leaf_key [lindex $dotted_key_hierarchy end] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + + #ensure empty keys are still represented in the datastructure + set table_keys [list] ;#We don't know the context - next level up will have to check for key collisions? + set test_keys $table_keys + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { + error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + } + ARRAY { + #arrays in toml are allowed to contain mixtures of types + set datastructure [list] + log::debug "--> processing array: $item" + + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + STRING { + set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + ITABLE { + #anonymous table + #lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + lappend datastructure [::tomlish::to_dict [list $element]] ;#store itables within arrays as raw dicts (possibly empty) + } + TABLE { + #invalid? shouldn't be output from from_dict - but could manually be constructed as such? review + #doesn't make sense as table needs a name? + #take as synonym for ITABLE? + error "to_dict TABLE within array unexpected" + } + ARRAY - MULTISTRING - MULTILITERAL { + #set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + } + WS - SEP - NEWLINE - COMMENT { + #ignore whitespace, commas, newlines and comments + } + default { + error "Unexpected value type '$type' found in array" + } + } + } + } + MULTILITERAL { + #triple squoted string + #first newline stripped only if it is the very first element + #(ie *immediately* following the opening delims) + #All whitespace other than newlines is within LITERALPARTS + # ------------------------------------------------------------------------- + #todo - consider extension to toml to allow indent-aware multiline literals + # how - propose as issue in toml github? Use different delim? e.g ^^^ ? + #e.g + # xxx=?'''abc + # def + # etc + # ''' + # - we would like to trimleft each line to the column following the opening delim + # ------------------------------------------------------------------------- + + log::debug "---> todict processing multiliteral: $item" + set parts [lrange $item 1 end] + if {[lindex $parts 0 0] eq "NEWLINE"} { + set parts [lrange $parts 1 end] ;#skip it + } + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + switch -exact -- $type { + LITERALPART { + append stringvalue [lindex $element 1] + } + NEWLINE { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + MULTISTRING { + #triple dquoted string + log::debug "---> to_dict processing multistring: $item" + set stringvalue "" + set idx 0 + set parts [lrange $item 1 end] + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + #We use STRINGPART in the tomlish representation as a distinct element to STRING - which would imply wrapping quotes to be reinserted + switch -exact -- $type { + STRING { + #todo - do away with STRING ? + #we don't build MULTISTRINGS containing STRING - but should we accept it? + tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" + append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" + } + STRINGPART { + append stringvalue [::tomlish::utils::unescape_string [lindex $element 1]] + } + CONT { + #When the last non-whitespace character on a line is an unescaped backslash, + #it will be trimmed along with all whitespace (including newlines) up to the next non-whitespace character or closing delimiter + # review - we allow some whitespace in stringpart elements - can a stringpart ever be all whitespace? + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + append stringvalue "\\" ;#add the sep + } else { + #skip over ws without emitting + set idx [llength $parts] + } + } else { + set parts_til_nl [lrange $parts 0 $next_nl-1] + set non_ws [lsearch -index 0 -start $idx+1 -not $parts_til_nl WS] + if {$non_ws >= 0} { + append stringvalue "\\" + } else { + #skip over ws on this line + set idx $next_nl + #then have to check each subsequent line until we get to first non-whitespace + set trimming 1 + while {$trimming && $idx < [llength $parts]} { + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + } else { + set idx [llength $parts] + } + set trimming 0 + } else { + set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + set trimming 0 + } else { + set idx $next_nl + #keep trimming + } + } + } + } + } + } + NEWLINE { + #if newline is first element - it is not part of the data of a multistring + if {$idx > 0} { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + } + WS { + append stringvalue [lindex $element 1] + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + WS - COMMENT - NEWLINE { + #ignore + } + default { + error "Unexpected tag '$tag' in Tomlish list '$tomlish'" + } + } + } + return $datastructure + } + + + proc _from_dictval_tomltype {parents tablestack keys typeval} { + set type [dict get $typeval type] + set val [dict get $typeval value] + switch -- $type { + ARRAY { + set subitems [list] + foreach item $val { + lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP + } + if {[lindex $subitems end] eq "SEP"} { + set subitems [lrange $subitems 0 end-1] + } + return [list ARRAY {*}$subitems] + } + ITABLE { + if {$val eq ""} { + return ITABLE + } else { + return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] + } + } + MULTISTRING { + #value is a raw string that isn't encoded as tomlish + #create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format + #We need to convert controls in $val to escape sequences - except for newlines + # + #consider an *option* to reformat for long lines? (perhaps overcomplex - byte equiv - but may fold in ugly places) + #we could use a line-length limit to decide when to put in a "line ending backslash" + #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW + # + #TODO + set tomlpart "x=\"\"\"\\\n" + append tomlpart $val "\"\"\"" + set tomlish [tomlish::decode::toml $tomlpart] + #e.g if val = " etc\nblah" + #TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } + #lindex 1 3 is the MULTISTRING tomlish list + return [lindex $tomlish 1 3] + } + MULTILITERAL { + #MLL string can contain newlines - but still no control chars + #todo - validate + set tomlpart "x='''\n" + append tomlpart $val ''' + set tomlish [tomlish::decode::toml $tomlpart] + return [lindex $tomlish 1 3] + } + LITERAL { + #from v1.0 spec - "Control characters other than tab are not permitted in a literal string" + #(This rules out raw ANSI SGR - which is somewhat restrictive - but perhaps justified for a config format + # as copy-pasting ansi to a config value is probably not always wise, and it's not something that can be + # easily input via a text editor. ANSI can go in Basic strings using the \e escape if that's accepted v1.1?) + #we could choose to change the type to another format here when encountering invalid chars - but that seems + #like too much magic. We elect to error out and require the dict to have valid data for the types it specifies. + if {[string first ' $val] >=0} { + error "_from_dictval_tomltype error: single quote found in LITERAL - cannot encode dict to TOML-VALID TOMLISH" + } + #detect control chars other than tab + #for this we can use rawstring_to_Bstring_with_escaped_controls - even though this isn't a Bstring + #we are just using the map to detect a difference. + set testval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val] + if {$testval ne $val} { + #some escaping would have to be done if this value was destined for a Bstring... + #therefor this string has controls and isn't suitable for a LITERAL according to the specs. + error "_from_dictval_tomltype error: control chars (other than tab) found in LITERAL value - cannot encode dict to TOML-VALID TOMLISH" + } + return [list LITERAL $val] + } + STRING { + return [list STRING [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val]] + } + INT { + if {![::tomlish::utils::is_int $val]} { + error "_from_dictval_tomltype error: bad INT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list INT $val] + } + FLOAT { + if {![::tomlish::utils::is_float $val]} { + error "_from_dictval_tomltype error: bad FLOAT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list FLOAT $val] + } + default { + if {$type ni [::tomlish::tags]} { + error "_from_dictval_tomltype error: Unrecognised typename '$type' in {type value } - cannot encode dict to TOML-VALID TOMLISH" + } + return [list $type $val] + } + } + } + + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + if {[regexp {\s} $k] || [string first . $k] >= 0} {} + if {![::tomlish::utils::is_barekey $k]} { + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + #requires quoting + #we'll use a basic mechanism for now to determine the type of quoting - whether it has any single quotes or not. + #todo - more? + #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) + if {[string first ' $k] >=0} { + #basic string + } else { + #literal string + set K_PART [list SQKEY $k] + } + } else { + set K_PART [list KEY $k] + } + puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" + puts stderr "---tablestack: $tablestack---" + set result [list] + set lastparent [lindex $parents end] + if {$lastparent in [list "" do_inline]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + set type [dict get $vinfo type] + #treat ITABLE differently? + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} + } else { + #set result [list TABLE $k {NEWLINE lf}] + if {$vinfo ne ""} { + + #set result [list DOTTEDKEY [list [list KEY $k]] = ] + #set records [list ITABLE] + + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + + if {$lastparent eq "do_inline"} { + set result [list DOTTEDKEY [list $K_PART] =] + set records [list ITABLE] + } else { + #review - quoted k ?? + set result [list TABLE $k {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $k]] + set records [list] + } + + + + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + dict for {vk vv} $vinfo { + if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + set VK_PART [list SQKEY $vk] + } else { + set VK_PART [list KEY $vk] + } + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] + } else { + if {$vv eq ""} { + #experimental + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" + #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] + set tname [join [list {*}$keys $vk] .] + set record [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + } else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + } + } else { + if { 0 } { + #experiment.. sort of getting there. + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" + set tname [join [list {*}$keys $vk] .] + set record [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + + #review - todo? + set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] + lappend record {*}$dottedkey_value + + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + } + if {$dictidx != $lastidx} { + #lappend record SEP + if {$lastparent eq "do_inline"} { + lappend record SEP + } else { + lappend record {NEWLINE lf} + } + } + lappend records $record + incr dictidx + } + if {$lastparent eq "do_inline"} { + lappend result $records {NEWLINE lf} + } else { + lappend result {*}$records {NEWLINE lf} + } + } else { + if {$lastparent eq "do_inline"} { + lappend result DOTTEDKEY [list [list KEY $k]] = ITABLE {NEWLINE lf} + } else { + lappend result TABLE $k {NEWLINE lf} + } + } + } + } else { + #lastparent is not toplevel "" or "do_inline" + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result {*}$sublist + } else { + if {$lastparent eq "TABLE"} { + #review + dict for {vk vv} $vinfo { + set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] + lappend result [list DOTTEDKEY [list [list KEY $vk]] = $dottedkey_value {NEWLINE lf}] + } + } else { + if {$vinfo ne ""} { + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + set sub [list] + #REVIEW + #set result $lastparent ;#e.g sets ITABLE + set result ITABLE + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + dict for {vk vv} $vinfo { + if {[regexp {\s} $vk] || [string first . $vk] >=0} { + set VK_PART [list SQKEY $vk] + } else { + set VK_PART [list KEY $vk] + } + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART] = $sublist] + } else { + if {$vv eq ""} { + #can't just uninline at this level + #we need a better method to query main dict for uninlinability at each level + # (including what's been inlined already) + #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + # puts stderr "_from_dictval uninline2 KEY $keys" + # set tname [join [list {*}$keys $vk] .] + # set record [list TABLE $tname {NEWLINE lf}] + # set tablestack [list {*}$tablestack [list T $vk]] + #} else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + #} + } else { + #set sub [_from_dictval ITABLE $vk $vv] + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + #set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + if {$dictidx != $lastidx} { + lappend record SEP + } + lappend result $record + incr dictidx + } + } else { + puts stderr "table x-1" + lappend result DOTTEDKEY [list $K_PART] = ITABLE + } + } + } + } + return $result + } + + + proc from_dict {d} { + #consider: + # t1={a=1,b=2} + # x = 1 + #If we represent t1 as an expanded table we get + # [t1] + # a=1 + # b=2 + # x=1 + # --- which is incorrect - as x was a toplevel key like t1! + #This issue doesn't occur if x is itself an inline table + # t1={a=1,b=2} + # x= {no="problem"} + # + # (or if we were to reorder x to come before t1) + + #As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} + #Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, + #which is unpreferred here. + + #A possible solution: + #scan the top level to see if all (trailing) elements are themselves dicts + # (ie not of form {type XXX value yyy}) + # + # A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements + #ie we don't need to force do_inline if all the 'simple' keys are before any compound keys + + #set root_has_values 0 + #approach 1) - the naive approach - forces inline when not always necessary + #dict for {k v} $d { + # if {[llength $v] == 4 && [lindex $v 0] eq "type"} { + # set root_has_values 1 + # break + # } + #} + + + #approach 2) - track the position of last {type x value y} in the dictionary built by to_dict + # - still not perfect. Inlines dotted tables unnecessarily + #This means from_dict doesn't produce output optimal for human editing. + set last_simple [tomlish::dict::last_tomltype_posn $d] + + + ## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values + #Any keys that are themselves tables - will need to be represented inline + #to avoid reordering, or incorrect assignment of plain values to the wrong table. + + ## set parent "" + #all toplevel keys in the dict structure can represent subtables. + #we are free to use {[tablename]\n} syntax for toplevel elements. + + + set tomlish [list TOMLISH] + set dictposn 0 + set tablestack [list [list T root]] ;#todo + dict for {t tinfo} $d { + if {$last_simple > $dictposn} { + set parents [list do_inline] + } else { + set parents [list ""] + } + set keys [list $t] + set trecord [_from_dictval $parents $tablestack $keys $tinfo] + lappend tomlish $trecord + incr dictposn + } + return $tomlish + } + + proc json_to_toml {json} { + #*** !doctools + #[call [fun json_to_toml] [arg json]] + #[para] + + set tomlish [::tomlish::from_json $json] + set toml [::tomlish::to_toml $tomlish] + } + + #TODO use huddle? + proc from_json {json} { + #set jstruct [::tomlish::json_struct $json] + #return [::tomlish::from_json_struct $jstruct] + package require huddle + package require huddle::json + set h [huddle::json::json2huddle parse $json] + + } + + proc from_json_struct {jstruct} { + package require fish::json_toml + return [fish::json_toml::jsonstruct2tomlish $jstruct] + } + + proc toml_to_json {toml} { + set tomlish [::tomlish::from_toml $toml] + return [::tomlish::get_json $tomlish] + } + + proc get_json {tomlish} { + package require fish::json + set d [::tomlish::to_dict $tomlish] + #return [::tomlish::dict_to_json $d] + return [fish::json::from "struct" $d] + } + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +namespace eval tomlish::build { + #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness + # take a value of the appropriate type and wrap as a tomlish tagged item + proc STRING {s} { + return [list STRING [::tomlish::utils::rawstring_to_Bstring_with_escaped_controls $s]] + } + proc LITERAL {litstring} { + + } + + proc INT {i} { + #whole numbers, may be prefixed with a + or - + #Leading zeros are not allowed + #Hex,octal binary forms are allowed (toml 1.0) + #We will error out on encountering commas, as commas are interpreted differently depending on locale (and don't seem to be supported in the toml spec anyway) + #!todo - Tcl can handle bignums - bigger than a 64bit signed long as specified in toml. + # - We should probably raise an error for number larger than this and suggest the user supply it as a string? + if {[tcl::string::last , $i] > -1} { + error "Unable to interpret '$i' as an integer. Use underscores if you need a thousands separator [::tomlish::parse::report_line]" + } + if {![::tomlish::utils::int_validchars $i]} { + error "Unable to interpret '$i' as an integer. Only 0-9 + 1 _ characters are acceptable. [::tomlish::parse::report_line]" + } + + if {[::tomlish::utils::is_int $i]} { + return [list INT $i] + } else { + error "'$i' is not a valid integer as per the Toml spec. [::tomlish::parse::report_line]" + } + + } + + proc FLOAT {f} { + #convert any non-lower case variants of special values to lowercase for Toml + if {[::tcl::string::tolower $f] in {nan +nan -nan inf +inf -inf}} { + return [list FLOAT [tcl::string::tolower $f]] + } + if {[::tomlish::utils::is_float $f]} { + return [list FLOAT $f] + } else { + error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" + } + } + + proc DATETIME {str} { + if {[::tomlish::utils::is_datetime $str]} { + return [list DATETIME $str] + } else { + error "Unable to interpret '$str' as Toml datetime. Check your input, or check that tomlish is able to handle all Toml datetimes properly [::tomlish::parse::report_line]" + } + } + + proc BOOLEAN {b} { + #convert any Tcl-acceptable boolean to boolean as accepted by toml - lower case true/false + if {![tcl::string::is boolean -strict $b]} { + error "Unable to convert '$b' to Toml boolean true|false. [::tomlish::parse::report_line]" + } else { + if {$b && 1} { + return [::list BOOL true] + } else { + return [::list BOOL false] + } + } + } + + #REVIEW + #Take tablename followed by + # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} + # (accept also key value {STRING }) + # b) simple 2-element tcl lists being name & *simple* value pairs for which basic heuristics will be used to determine types + proc _table {name args} { + set pairs [list] + foreach t $args { + if {[llength $t] == 4} { + if {[tcl::string::tolower [lindex $t 0]] ne "key" || [tcl::string::tolower [lindex $t 2]] ni "= value"} { + error "Only items tagged as KEY = currently accepted as name-value pairs for table command" + } + lassign $t _k keystr _eq valuepart + if {[llength $valuepart] != 2} { + error "supplied value must be typed. e.g {INT 1} or {STRING test}" + } + lappend pairs [list KEY $keystr = $valuepart] + } elseif {[llength $t] == 2} { + #!todo - type heuristics + lassign $t n v + lappend pairs [list KEY $n = [list STRING $v]] + } else { + error "'KEY = { toml but + # the first newline is not part of the data. + # we elect instead to maintain a basic LITERALPART that must not contain newlines.. + # and to compose MULTILITERAL of multiple NEWLINE LITERALPART parts, + #with the datastructure representation dropping the first newline (if immediately following opening delim) when building the value. + set literal "" + foreach part [lrange $item 1 end] { + append literal [::tomlish::encode::tomlish [list $part] $nextcontext] + } + append toml '''$literal''' + } + INT - + BOOL - + FLOAT - + DATETIME { + append toml [lindex $item 1] + } + INCOMPLETE { + error "cannot process tomlish term tagged as INCOMPLETE" + } + COMMENT { + append toml "#[lindex $item 1]" + } + BOM { + #Byte Order Mark may appear at beginning of a file. Needs to be preserved. + append toml "\uFEFF" + } + default { + error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command." + } + } + + } + return $toml + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::encode ---}] +} +#fish toml from tomlish + +#(encode tomlish as toml) +interp alias {} tomlish::to_toml {} tomlish::encode::tomlish + +# + + +namespace eval tomlish::decode { + #*** !doctools + #[subsection {Namespace tomlish::decode}] + #[para] + #[list_begin definitions] + + #return a Tcl list of tomlish tokens + #i.e get a standard list of all the toml terms in string $s + #where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. + #(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) + # ---------------------------------------------------------------------------------------------- + # NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! + # e.g we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- + #Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. + # (e.g perhaps a toml editor to highlight violations for fixing) + # A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. + # e.g dicts or an object oriented structure + #Note also - *no* escapes in quoted strings are processed. This is up to the datastructure stage + #e.g to_dict will substitute \r \n \uHHHH \UHHHHHHH etc + #This is important for tomlish to maintain the ability to perform competely lossless round-trips from toml to tomlish and back to toml. + # (which is handy for testing as well as editing some part of the structure with absolutely no effect on other parts of the document) + #If we were to unescape a tab character for example + # - we have no way of knowing if it was originally specified as \t \u0009 or \U00000009 or directly as a tab character. + # For this reason, we also do absolutely no line-ending transformations based on platform. + # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + + proc toml {args} { + #*** !doctools + #[call [fun toml] [arg arg...]] + #[para] return a Tcl list of tomlish tokens + + set s [join $args \n] + + namespace upvar ::tomlish::parse is_parsing is_parsing + set is_parsing 1 + + if {[info command ::tomlish::parse::spacestack] eq "::tomlish::parse::spacestack"} { + tomlish::parse::spacestack destroy + } + struct::stack ::tomlish::parse::spacestack + + namespace upvar ::tomlish::parse last_space_action last_space_action + namespace upvar ::tomlish::parse last_space_type last_space_type + + namespace upvar ::tomlish::parse tok tok + set tok "" + + namespace upvar ::tomlish::parse type type + namespace upvar ::tomlish::parse tokenType tokenType + ::tomlish::parse::set_tokenType "" + namespace upvar ::tomlish::parse tokenType_list tokenType_list + set tokenType [list] ;#Flat (un-nested) list of tokentypes found + + namespace upvar ::tomlish::parse lastChar lastChar + set lastChar "" + + + set result "" + namespace upvar ::tomlish::parse nest nest + set nest 0 + + namespace upvar ::tomlish::parse v v ;#array keyed on nest level + + + set v(0) {TOMLISH} + array set s0 [list] ;#whitespace data to go in {SPACE {}} element. + set parentlevel 0 + + namespace upvar ::tomlish::parse i i + set i 0 + + namespace upvar ::tomlish::parse state state + + namespace upvar ::tomlish::parse braceCount braceCount + set barceCount 0 + namespace upvar ::tomlish::parse bracketCount bracketCount + set bracketCount 0 + + set sep 0 + set r 1 + namespace upvar ::tomlish::parse token_waiting token_waiting + set token_waiting [dict create] ;#if ::tok finds a *complete* second token during a run, it will put the 2nd one here to be returned by the next call. + + + set state "table-space" + ::tomlish::parse::spacestack push {type space state table-space} + namespace upvar ::tomlish::parse linenum linenum;#'line number' of input data. (incremented for each literal linefeed - but not escaped ones in data) + set linenum 1 + + set ::tomlish::parse::state_list [list] + try { + while {$r} { + set r [::tomlish::parse::tok $s] + #puts stdout "got tok: '$tok' while parsing string '$s' " + set next_tokenType_known 0 ;#whether we begin a new token here based on what terminated the token result of 'tok' + + + #puts "got token: '$tok' tokenType='$tokenType'. while v($nest) = [set v($nest)]" + #puts "-->tok: $tok tokenType='$tokenType'" + set prevstate $state + set transition_info [::tomlish::parse::goNextState $tokenType $tok $state] + #review goNextState could perform more than one space_action + set space_action [dict get $transition_info space_action] + set newstate [dict get $transition_info newstate] ;#use of 'newstate' vs 'state' makes code clearer below + + if {[tcl::string::match "err-*" $state]} { + ::tomlish::log::warn "---- State error in state $prevstate for tokenType: $tokenType token value: $tok. $state aborting parse. [tomlish::parse::report_line]" + lappend v(0) [list ERROR tokentype $tokenType state $prevstate to $state leveldata [set v($nest)]] + return $v(0) + } + # --------------------------------------------------------- + #NOTE there may already be a token_waiting at this point + #set_token_waiting can raise an error here, + # in which case the space_action branch needs to be rewritten to handle the existing token_waiting + # --------------------------------------------------------- + + if {$space_action eq "pop"} { + #pop_trigger_tokens: newline tablename endarray endinlinetable + #note a token is a pop trigger depending on context. e.g first newline during keyval is a pop trigger. + set parentlevel [expr {$nest -1}] + set do_append_to_parent 1 ;#most tokens will leave this alone - but some like squote_seq need to do their own append + switch -exact -- $tokenType { + squote_seq { + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the xxx-squote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + switch -- $tok { + ' { + tomlish::parse::set_token_waiting type startsquote value $tok complete 1 startindex [expr {$i -1}] + } + '' { + #review - we should perhaps return double_squote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_squote value "" complete 1 startindex [expr {$i - 2}] + } + ''' { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 3}] + } + '''' { + switch -exact -- $prevstate { + leading-squote-space { + error "---- 4 squotes from leading-squote-space - shouldn't get here" + #we should have emitted the triple and left the last for next loop + } + trailing-squote-space { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left squote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]'" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "'"] + } + default { + error "--- don't know how to integrate extra trailing squote with data $v($parentlevel)" + } + } + } + default { + error "--- unexpected popped due to squote_seq but came from state '$prevstate' should have been leading-squote-space or trailing-squote-space" + } + } + } + ''''' { + switch -exact -- $prevstate { + leading-squote-space { + error "---- 5 squotes from leading-squote-space - shouldn't get here" + #we should have emitted the triple and left the following squotes for next loop + } + trailing-squote-space { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 squotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]''" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [LITERALPART "''"] + } + default { + error "--- don't know how to integrate extra trailing 2 squotes with data $v($parentlevel)" + } + } + } + default { + error "--- unexpected popped due to squote_seq but came from state '$prevstate' should have been leading-squote-space or trailing-squote-space" + } + } + } + } + puts stderr "tomlish::decode::toml ---- HERE squote_seq pop <$tok>" + } + triple_squote { + #presumably popping multiliteral-space + ::tomlish::log::debug "---- triple_squote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTILITERAL { + lappend merged $part + } + LITERALPART { + if {$lasttype eq "LITERALPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_squote unhandled part type [lindex $part 0] unable to merge leveldata: $v($next)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + equal { + #pop caused by = + switch -exact -- $prevstate { + dottedkey-space { + tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + dottedkey-space-tail { + #experiment? + tomlish::log::debug "---- equal ending dottedkey-space-tail for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + } + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + tablename { + #note: a tablename only 'pops' if we are greater than zero + error "---- tablename pop should already have been handled as special case zeropoppushspace in goNextState" + } + tablearrayname { + #!review - tablearrayname different to tablename regarding push/pop? + #note: a tablename only 'pops' if we are greater than zero + error "---- tablearrayname pop should already have been handled as special case zeropoppushspace in goNextState" + } + endarray { + #nothing to do here. + } + comma { + #comma for inline table will pop the keyvalue space + lappend v($nest) "SEP" + } + endinlinetable { + ::tomlish::log::debug "---- endinlinetable for last_space_action pop" + } + endmultiquote { + ::tomlish::log::debug "---- endmultiquote for last_space_action 'pop'" + } + default { + error "---- unexpected tokenType '$tokenType' for last_space_action 'pop'" + } + } + if {$do_append_to_parent} { + #e.g squote_seq does it's own appends as necessary - so won't get here + lappend v($parentlevel) [set v($nest)] + } + + incr nest -1 + + } elseif {$last_space_action eq "push"} { + set prevnest $nest + incr nest 1 + set v($nest) [list] + # push_trigger_tokens: barekey dquotedkey startinlinetable startarray tablename tablearrayname + + + switch -exact -- $tokenType { + squote_seq_begin { + #### + if {[dict exists $transition_info starttok] && [dict get $transition_info starttok] ne ""} { + lassign [dict get $transition_info starttok] starttok_type starttok_val + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType $starttok_type + set tok $starttok_val + } + } + squotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + dquotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + XXXdquotedkey - XXXitablequotedkey { + #todo + set v($nest) [list DQKEY $tok] ;#$tok is the keyname + } + barekey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + set waiting [tomlish::parse::get_token_waiting] + if {[llength $waiting]} { + set i [dict get $waiting startindex] + tomlish::parse::clear_token_waiting + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } else { + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + } + startsquote { + #JMN + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + tablename { + #note: we do not use the output of tomlish::tablename_trim to produce a tablename for storage in the tomlish list! + #The tomlish list is intended to preserve all whitespace (and comments) - so a roundtrip from toml file to tomlish + # back to toml file will be identical. + #It is up to the datastructure stage to normalize and interpret tomlish for programmatic access. + # we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, + # so we can raise an error at this point rather than create a tomlish list with obviously invalid table names. + + #todo - review! It's arguable that we should not do any validation here, and just store even incorrect raw tablenames, + # so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the + # tomlish list? + + set test_only [::tomlish::utils::tablename_trim $tok] + ::tomlish::log::debug "---- trimmed (but not normalized) tablename: '$test_only'" + set v($nest) [list TABLE $tok] ;#$tok is the *raw* table name + #note also that equivalent tablenames may have different toml representations even after being trimmed! + #e.g ["x\t\t"] & ["x "] (tab escapes vs literals) + #These will show as above in the tomlish list, but should normalize to the same tablename when used as keys by the datastructure stage. + } + tablearrayname { + set test_only [::tomlish::utils::tablename_trim $tok] + puts stdout "trimmed (but not normalized) tablearrayname: '$test_only'" + set v($nest) [list TABLEARRAY $tok] ;#$tok is the *raw* tablearray name + } + startarray { + set v($nest) [list ARRAY] ;#$tok is just the opening bracket - don't output. + } + startinlinetable { + set v($nest) [list ITABLE] ;#$tok is just the opening curly brace - don't output. + } + startmultiquote { + ::tomlish::log::debug "---- push trigger tokenType startmultiquote" + set v($nest) [list MULTISTRING] ;#container for STRINGPART, WS, CONT, NEWLINE + } + triple_squote { + ::tomlish::log::debug "---- push trigger tokenType triple_squote" + set v($nest) [list MULTILITERAL] ;#container for NEWLINE,LITERAL + } + default { + error "---- push trigger tokenType '$tokenType' not yet implemented" + } + } + + } else { + #no space level change + switch -exact -- $tokenType { + squotedkey { + puts "---- squotedkey in state $prevstate (no space level change)" + lappend v($nest) [list SQKEY $tok] + } + dquotedkey { + puts "---- dquotedkey in state $prevstate (no space level change)" + lappend v($nest) [list DQKEY $tok] + } + barekey { + lappend v($nest) [list KEY $tok] + } + dotsep { + lappend v($nest) [list DOTSEP] + } + starttablename { + #$tok is triggered by the opening bracket and sends nothing to output + } + starttablearrayname { + #$tok is triggered by the double opening brackets and sends nothing to output + } + tablename - tablenamearray { + error "---- did not expect 'tablename/tablearrayname' without space level change (no space level change)" + #set v($nest) [list TABLE $tok] + } + endtablename - endtablearrayname { + #no output into the tomlish list for this token + } + startinlinetable { + puts stderr "---- decode::toml error. did not expect startinlinetable without space level change (no space level change)" + } + startquote { + switch -exact -- $newstate { + string-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "string" + set tok "" + } + quoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "dquotedkey" + set tok "" + } + XXXitable-quoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "itablequotedkey" + set tok "" + } + default { + error "---- startquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + startsquote { + switch -exact -- $newstate { + literal-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "literal" + set tok "" + } + squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + XXXitable-squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "itablesquotedkey" + set tok "" + } + multiliteral-space { + #false alarm squote returned from squote_seq pop + ::tomlish::log::debug "---- adding lone squote to own LITERALPART nextstate: $newstate (no space level change)" + #(single squote - not terminating space) + lappend v($nest) [list LITERALPART '] + #may need to be joined on pop if there are neighbouring LITERALPARTs + } + default { + error "---- startsquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + startmultiquote { + #review + puts stderr "---- got startmultiquote in state $prevstate (no space level change)" + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "stringpart" + set tok "" + } + endquote { + #nothing to do? + set tok "" + } + endsquote { + set tok "" + } + endmultiquote { + #JMN!! + set tok "" + } + string { + lappend v($nest) [list STRING $tok] ;#directly wrapped in dquotes + } + literal { + lappend v($nest) [list LITERAL $tok] ;#directly wrapped in squotes + } + double_squote { + switch -exact -- $prevstate { + keyval-value-expected { + lappend v($nest) [list LITERAL ""] + } + multiliteral-space { + #multiliteral-space to multiliteral-space + lappend v($nest) [list LITERALPART ''] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + multistring { + #review + lappend v($nest) [list MULTISTRING $tok] + } + stringpart { + lappend v($nest) [list STRINGPART $tok] ;#will not get wrapped in dquotes directly + } + multiliteral { + lappend v($nest) [LIST MULTILITERAL $tok] + } + literalpart { + lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly + } + itablequotedkey { + + } + untyped_value { + #we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. + if {$tok in {true false}} { + set tag BOOL + } elseif {[::tomlish::utils::is_int $tok]} { + set tag INT + } elseif {[::tomlish::utils::is_float $tok]} { + set tag FLOAT + } elseif {[::tomlish::utils::is_datetime $tok]} { + set tag DATETIME + } else { + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + } + lappend v($nest) [list $tag $tok] + + } + comment { + #puts stdout "----- comment token returned '$tok'------" + lappend v($nest) [list COMMENT "$tok"] + } + equal { + #we append '=' to the nest so that any surrounding whitespace is retained. + lappend v($nest) = + } + comma { + lappend v($nest) SEP + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + whitespace { + lappend v($nest) [list WS $tok] + } + continuation { + lappend v($nest) CONT + } + bom { + lappend v($nest) BOM + } + eof { + #ok - nothing more to add to the tomlish list. + #!todo - check previous tokens are complete/valid? + } + default { + error "--- unknown tokenType '$tokenType' during state $prevstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + + if {!$next_tokenType_known} { + ::tomlish::log::notice "---- tomlish::decode::toml - current tokenType:$tokenType Next token type not known" + ::tomlish::parse::set_tokenType "" + set tok "" + } + + if {$state eq "end-state"} { + break + } + + + } + + #while {$nest > 0} { + # lappend v([expr {$nest -1}]) [set v($nest)] + # incr nest -1 + #} + while {[::tomlish::parse::spacestack size] > 1} { + ::tomlish::parse::spacestack pop + lappend v([expr {$nest -1}]) [set v($nest)] + incr nest -1 + + #set parent [spacestack peek] ;#the level being appended to + #lassign $parent type state + #if {$type eq "space"} { + # + #} elseif {$type eq "buffer"} { + # lappend v([expr {$nest -1}]) {*}[set v($nest)] + #} else { + # error "invalid spacestack item: $parent" + #} + } + + } finally { + set is_parsing 0 + } + return $v(0) + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::decode ---}] +} +#decode toml to tomlish +interp alias {} tomlish::from_toml {} tomlish::decode::toml + +namespace eval tomlish::utils { + #*** !doctools + #[subsection {Namespace tomlish::utils}] + #[para] + #[list_begin definitions] + + + #tablenames (& tablearraynames) may contain irrelevant leading, trailing and interspersed whitespace + # tablenames can be made up of segments delimited by dots. .eg [ a.b . c ] + #trimmed, the tablename becomes {a.b.c} + # A segment may contain whitespace if it is quoted e.g [a . b . "c etc " ] + #ie whitespace is only irrelevant if it's outside a quoted segment + #trimmed, the tablename becomes {a.b."c etc "} + proc tablename_trim {tablename} { + set segments [tablename_split $tablename false] + set trimmed_segments [list] + foreach seg $segments { + lappend trimmed_segments [::string trim $seg " \t"] + } + return [join $trimmed_segments .] + } + + #basic generic quote matching for single and double quotes + #note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes + proc tok_in_quotedpart {tok} { + set sLen [tcl::string::length $tok] + set quote_type "" + set had_slash 0 + for {set i 0} {$i < $sLen} {incr i} { + set c [tcl::string::index $tok $i] + if {$quote_type eq ""} { + if {$had_slash} { + #don't enter quote mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + set quote_type dq + } + sq { + set quote_type sq + } + bsl { + set had_slash 1 + } + } + } + } else { + if {$had_slash} { + #don't leave quoted mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + if {$quote_type eq "dq"} { + set quote_type "" + } + } + sq { + if {$quote_type eq "sq"} { + set quote_type "" + } + } + bsl { + set had_slash 1 + } + } + } + } + } + return $quote_type ;#dq | sq + } + + #utils::tablename_split + proc tablename_split {tablename {normalize false}} { + #we can't just split on . because we have to handle quoted segments which may contain a dot. + #eg {dog."tater.man"} + set sLen [tcl::string::length $tablename] + set segments [list] + set mode "unknown" ;#5 modes: unknown, quoted,litquoted, unquoted, syntax + #quoted is for double-quotes, litquoted is for single-quotes (string literal) + set seg "" + for {set i 0} {$i < $sLen} {incr i} { + + if {$i > 0} { + set lastChar [tcl::string::index $tablename [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $tablename $i] + + if {$c eq "."} { + switch -exact -- $mode { + unquoted { + #dot marks end of segment. + lappend segments $seg + set seg "" + set mode "unknown" + } + quoted { + append seg $c + } + unknown { + lappend segments $seg + set seg "" + } + litquoted { + append seg $c + } + default { + #mode: syntax + #we got our dot. - the syntax mode is now satisfied. + set mode "unknown" + } + } + } elseif {($c eq "\"") && ($lastChar ne "\\")} { + if {$mode eq "unknown"} { + if {[tcl::string::trim $seg] ne ""} { + #we don't allow a quote in the middle of a bare key + error "tablename_split. character '\"' invalid at this point in tablename. tablename: '$tablename'" + } + set mode "quoted" + set seg "\"" + } elseif {$mode eq "unquoted"} { + append seg $c + } elseif {$mode eq "quoted"} { + append seg $c + + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + } else { + lappend segments $seg + } + + set seg "" + set mode "syntax" ;#make sure we only accept a dot or end-of-data now. + } elseif {$mode eq "litquoted"} { + append seg $c + } elseif {$mode eq "syntax"} { + error "tablename_split. expected whitespace or dot, got double quote. tablename: '$tablename'" + } + } elseif {($c eq "\'")} { + if {$mode eq "unknown"} { + append seg $c + set mode "litquoted" + } elseif {$mode eq "unquoted"} { + #single quote inside e.g o'neill + append seg $c + } elseif {$mode eq "quoted"} { + append seg $c + + } elseif {$mode eq "litquoted"} { + append seg $c + #no normalization to do + lappend segments $seg + set seg "" + set mode "syntax" + } elseif {$mode eq "syntax"} { + error "tablename_split. expected whitespace or dot, got single quote. tablename: '$tablename'" + } + + } elseif {$c in [list " " \t]} { + if {$mode eq "syntax"} { + #ignore + } else { + append seg $c + } + } else { + if {$mode eq "syntax"} { + error "tablename_split. Expected a dot separator. got '$c'. tablename: '$tablename'" + } + if {$mode eq "unknown"} { + set mode "unquoted" + } + append seg $c + } + if {$i == $sLen-1} { + #end of data + ::tomlish::log::debug "End of data: mode='$mode'" + #REVIEW - we can only end up in unquoted or syntax here? are other branches reachable? + switch -exact -- $mode { + quoted { + if {$c ne "\""} { + error "tablename_split. missing closing double-quote in a segment. tablename: '$tablename'" + } + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + #lappend segments [subst -nocommands -novariables [::string range $seg 1 end-1]] ;#wrong + } else { + lappend segments $seg + } + } + litquoted { + set trimmed_seg [tcl::string::trim $seg] + if {[tcl::string::index $trimmed_seg end] ne "\'"} { + error "tablename_split. missing closing single-quote in a segment. tablename: '$tablename'" + } + lappend segments $seg + } + unquoted - unknown { + lappend segments $seg + } + syntax { + #ok - segment already lappended + } + default { + lappend segments $seg + } + } + } + } + foreach seg $segments { + set trimmed [tcl::string::trim $seg " \t"] + #note - we explicitly allow 'empty' quoted strings '' & "" + # (these are 'discouraged' but valid toml keys) + #if {$trimmed in [list "''" "\"\""]} { + # puts stderr "tablename_split. warning - Empty quoted string as tablename segment" + #} + if {$trimmed eq "" } { + error "tablename_split. Empty segment found. tablename: '$tablename' segments [llength $segments] ($segments)" + } + } + return $segments + } + + proc unicode_escape_info {slashu} { + #!todo + # validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and + # is a valid 'unicode scalar value' (any Unicode code point except high-surrogate and low-surrogate code points) + # ie integers in the range 0 to D7FF16 and E00016 to 10FFFF16 inclusive + #expr {(($x >= 0) && ($x <= 0xD7FF16)) || (($x >= 0xE00016) && ($x <= 0x10FFFF16))} + if {[tcl::string::match {\\u*} $slashu]} { + set exp {^\\u([0-9a-fA-F]{4}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %4x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } + } else { + return [list err [list reason "Supplied string not of the form \\uHHHH where H in \[0-9a-fA-F\]"]] + } + } elseif {[tcl::string::match {\\U*} $slashu]} { + set exp {^\\U([0-9a-fA-F]{8}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %8x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + if {(($dec >= 0) && ($dec <= 0xD7FF16)) || (($dec >= 0xE00016) && ($dec <= 0x10FFFF16))} { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } else { + return [list err [list reason "$slashu is not within the 'unicode scalar value' ranges 0 to 0xD7FF16 or 0xE00016 to 0x10FFFF16"]] + } + } + } else { + return [list err [list reason "Supplied string not of the form \\UHHHHHHHH where H in \[0-9a-fA-F\]"]] + } + } else { + return [list err [list reason "Supplied string did not start with \\u or \\U" ]] + } + + } + + #Note that unicode characters don't *have* to be escaped. + #So if we provide a function named 'escape_string', the name implies the inverse of unescape_string which unescapes unicode \u \U values. + #- an inverse of unescape_string would encode all unicode chars unnecessarily. + #- as toml accepts a compact escape sequence for common chars such as tab,backspace,linefeed etc but also allows the full form \u009 etc + #- escape_string and unescape_string would not be reliably roundtrippable inverses anyway. + #REVIEW - provide it anyway? When would it be desirable to use? + + variable Bstring_control_map [list\ + \b {\b}\ + \n {\n}\ + \r {\r}\ + \" {\"}\ + \x1b {\e}\ + \\ "\\\\"\ + ] + #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ + #for a Bstring (Basic string) tab is explicitly mentioned as not being one that must be escaped. + for {set cdec 0} {$cdec <= 8} {incr cdec} { + set hhhh [format %.4X $cdec] + lappend Bstring_control_map [format %c $cdec] \\u$hhhh + } + for {set cdec [expr {0x0A}]} {$cdec <= 0x1F} {incr cdec} { + set hhhh [format %.4X $cdec] + lappend Bstring_control_map [format %c $cdec] \\u$hhhh + } + # \u007F = 127 + lappend Bstring_control_map [format %c 127] \\u007F + + #Note the inclusion of backslash in the list of controls makes this non idempotent - subsequent runs would keep encoding the backslashes! + #escape only those chars that must be escaped in a Bstring (e.g not tab which can be literal or escaped) + #for example - can be used by from_dict to produce valid Bstring data for a tomlish record + proc rawstring_to_Bstring_with_escaped_controls {str} { + #for the well known chars that have compact escape sequences allowed by toml - we choose that form over the full \u form. + #we'll use a string map with an explicit list rather than algorithmic at runtime + # - the string map is probably more performant than splitting a string, especially if it's large + variable Bstring_control_map + return [string map $Bstring_control_map $str] + } + + #review - unescape what string? Bstring vs MLBstring? + #we should be specific in the function naming here + #used by to_dict - so part of validation? - REVIEW + proc unescape_string {str} { + #note we can't just use Tcl subst because: + # it also transforms \a (audible bell) and \v (vertical tab) which are not in the toml spec. + # it would strip out backslashes inappropriately: e.g "\j" becomes just j + # it recognizes other escapes which aren't approprite e.g \xhh and octal \nnn + # it replaces \ with a single whitespace (trailing backslash) + #This means we shouldn't use 'subst' on the whole string, but instead substitute only the toml-specified escapes (\r \n \b \t \f \\ \" \uhhhh & \Uhhhhhhhh + + set buffer "" + set buffer4 "" ;#buffer for 4 hex characters following a \u + set buffer8 "" ;#buffer for 8 hex characters following a \u + + set sLen [tcl::string::length $str] + + #we need to handle arbitrarily long sequences of backslashes. \\\\\ etc + set slash_active 0 + set unicode4_active 0 + set unicode8_active 0 + + ::tomlish::log::debug "unescape_string. got len [string length str] str $str" + + #!todo - check for invalid data in the form of a raw carriage return (decimal 13) without following linefeed? + set i 0 + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $str [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $str $i] + #::tomlish::log::debug "unescape_string. got char $c" ;#too much? + + #---------------------- + #as we are 'unescaping' - should we really be testing for existing values that should have been escaped? + #this test looks incomplete anyway REVIEW + scan $c %c n + if {($n <= 31) && ($n != 9) && ($n != 10) && ($n != 13)} { + #we don't expect unescaped unicode characters from 0000 to 001F - + #*except* for raw tab (which is whitespace) and newlines + error "unescape_string. Invalid data for a toml string. Unescaped control character (decimal $n) [::tomlish::utils::string_to_slashu $c]" + } + #---------------------- + + incr i ;#must incr here because we do'returns'inside the loop + if {$c eq "\\"} { + if {$slash_active} { + append buffer "\\" + set slash_active 0 + } elseif {$unicode4_active} { + error "unescape_string. unexpected case slash during unicode4 not yet handled" + } elseif {$unicode8_active} { + error "unescape_string. unexpected case slash during unicode8 not yet handled" + } else { + # don't output anything (yet) + set slash_active 1 + } + } else { + if {$unicode4_active} { + if {[tcl::string::length $buffer4] < 4} { + append buffer4 $c + } + if {[tcl::string::length $buffer4] == 4} { + #we have a \uHHHH to test + set unicode4_active 0 + set result [tomlish::utils::unicode_escape_info "\\u$buffer4"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$unicode8_active} { + if {[tcl::string::length $buffer8] < 8} { + append buffer8 $c + } + if {[tcl::string::length $buffer8] == 8} { + #we have a \UHHHHHHHH to test + set unicode8_active 0 + set result [tomlish::utils::unicode_escape_info "\\U$buffer8"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$slash_active} { + set slash_active 0 + set ctest [tcl::string::map {{"} dq} $c] + switch -exact -- $ctest { + dq { + set e "\\\"" + append buffer [subst -nocommand -novariable $e] + } + b - t - n - f - r { + set e "\\$c" + append buffer [subst -nocommand -novariable $e] + } + u { + set unicode4_active 1 + set buffer4 "" + } + U { + set unicode8_active 1 + set buffer8 "" + } + default { + set slash_active 0 + #review - toml spec says all other escapes are reserved + #and if they are used TOML should produce an error. + #we leave detecting this for caller for now - REVIEW + append buffer "\\" + append buffer $c + } + } + } else { + append buffer $c + } + } + } + #puts stdout "EOF 4:$unicode4_active 8:$unicode8_active slash:$slash_active" + if {$unicode4_active} { + error "End of string reached before complete unicode escape sequence \uHHHH" + } + if {$unicode8_active} { + error "End of string reached before complete unicode escape sequence \UHHHHHHHH" + } + if {$slash_active} { + append buffer "\\" + } + return $buffer + } + + #This does not have to do with unicode normal forms - which it seems toml has decided against regarding use in keys (review/references?) + #This is meant for internal use regarding ensuring we match equivalent keys which may have just been specified with different string mechanisms, + #e.g squoted vs dquoted vs barekey. + proc normalize_key {rawkey} { + set c1 [tcl::string::index $rawkey 0] + set c2 [tcl::string::index $rawkey end] + if {($c1 eq "'") && ($c2 eq "'")} { + #single quoted segment. No escapes allowed within it. + set key [tcl::string::range $rawkey 1 end-1] + } elseif {($c1 eq "\"") && ($c2 eq "\"")} { + #double quoted segment. Apply escapes. + # + set keydata [tcl::string::range $rawkey 1 end-1] ;#strip outer quotes only + #e.g key could have mix of \UXXXXXXXX escapes and unicode chars + #or mix of \t and literal tabs. + #unescape to convert all to literal versions for comparison + set key [::tomlish::utils::unescape_string $keydata] + #set key [subst -nocommands -novariables $keydata] ;#wrong. Todo - create a string escape substitution function. + } else { + set key $rawkey + } + return $key + } + + proc string_to_slashu {string} { + set rv {} + foreach c [split $string {}] { + scan $c %c cdec + if {$cdec > 65535} { + append rv {\U} [format %.8X $cdec] + } else { + append rv {\u} [format %.4X $cdec] + } + } + return $rv + } + + #'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. + #This is used for display purposes only (error msgs) + proc nonprintable_to_slashu {s} { + set res "" + foreach i [split $s ""] { + scan $i %c cdec + + set printable 0 + if {($cdec>31) && ($cdec<127)} { + set printable 1 + } + if {$printable} { + append res $i + } else { + if {$cdec > 65535} { + append res \\U[format %.8X $cdec] + } else { + append res \\u[format %.4X $cdec] + } + } + } + set res + } ;# initial version from tcl wiki RS + + #check if str is valid for use as a toml bare key + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } else { + set matches [regexp -all {[a-zA-Z0-9\_\-]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters match the regexp + return 1 + } else { + return 0 + } + } + } + + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + + #test only that the characters in str are valid for the toml specified type 'integer'. + proc int_validchars1 {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_\-\+]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + #add support for hex,octal,binary 0x.. 0o.. 0b... + proc int_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_int {str} { + set matches [regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + + # --------------------------------------- + #check for leading zeroes in non 0x 0b 0o + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + if {([tcl::string::length $check] > 1) && ([tcl::string::index $check 0] eq "0") && ([tcl::string::index $check 1] ni {o x b})} { + return 0 + } + # --------------------------------------- + + #check +,- only occur in the first position. + if {[tcl::string::last - $str] > 0} { + return 0 + } + if {[tcl::string::last + $str] > 0} { + return 0 + } + set numeric_value [tcl::string::map {_ ""} $str] ;#allow some earlier tcl versions which don't support underscores + #use Tcl's integer check to ensure we don't let things like 3e4 through - which is a float (would need to be 0x3e4 for hex) + if {![tcl::string::is integer -strict $numeric_value]} { + return 0 + } + #!todo - check bounds only based on some config value + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements. + #presumably very large numbers would have to be supplied in a toml file as strings. + #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max + if {$numeric_value > $::tomlish::max_int} { + return 0 + } + if {$numeric_value < $::tomlish::min_int} { + return 0 + } + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'float'. + proc float_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[eE0-9\_\-\+\.]} $str] == $numchars} { + return 1 + } else { + #only allow lower case for these special values - as per Toml 1.0 spec + if {$str ni {inf +inf -inf nan +nan -nan}} { + return 0 + } else { + return 1 + } + } + } + + proc is_float {str} { + set matches [regexp -all {[eE0-9\_\-\+\.]} $str] + #don't test for case variations - as Toml doesn't allow (whereas Tcl allows Inf NaN etc) + if {$str in {inf +inf -inf nan +nan -nan}} { + return 1 + } + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + #A leading zero is ok, but we should disallow multiple leading zeroes (same rules as toml ints) + #Toml spec also disallows leading zeros in the exponent part + #... but this seems less interoperable (some libraries generate leading zeroes in exponents) + #for now we will allow leading zeros in exponents + #!todo - configure 'strict' option to disallow? + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + set r {([0-9])*} + regexp $r $check intpart ;#intpart holds all numerals before the first .,e or E + set z {([0])*} + regexp $z $intpart leadingzeros + if {[tcl::string::length $leadingzeros] > 1} { + return 0 + } + #for floats, +,- may occur in multiple places + #e.g -2E-22 +3e34 + #!todo - check bounds ? + + #strip underscores for tcl double check + set check [tcl::string::map {_ ""} $str] + #string is double accepts inf nan +NaN etc. + if {![tcl::string::is double $check]} { + return 0 + } + + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'datetime'. + proc datetime_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[zZtT0-9\-\+\.:]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + #review - we + proc is_datetime {str} { + #e.g 1979-05-27 + #e.g 1979-05-27T00:32:00Z + #e.g 1979-05-27 00:32:00-07:00 + #e.g 1979-05-27 00:32:00+10:00 + #e.g 1979-05-27 00:32:00.999999-07:00 + + #review + #minimal datetimes? + # 2024 ok - shortest valid 4 digit year? + # 02:00 ok + # 05-17 ok + if {[string length $str] < 4} { + return 0 + } + + set matches [regexp -all {[zZtT0-9\-\+\.:]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + #!todo - use full RFC 3339 parser? + lassign [split $str T] datepart timepart + #!todo - what if the value is 'time only'? + + #Tcl's free-form clock scan (no -format option) is deprecated + # + #if {[catch {clock scan $datepart} err]} { + # puts stderr "tcl clock scan failed err:'$err'" + # return 0 + #} + + #!todo - verify time part is reasonable + } else { + return 0 + } + return 1 + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::utils ---}] +} + +namespace eval tomlish::parse { + #*** !doctools + #[subsection {Namespace tomlish::parse}] + #[para] + #[list_begin definitions] + + #This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases. + #The code is a pig's-nest - but it should be noted that for example trailing single double quotes in multiline strings are perhaps not so trivial to parse using more standard methods either: + # - e.g some kind of backtracking required if using an ABNF parser? + #I don't know the precise technical name for this sort of parser; probably something like "Dog's Breakfast" + #More seriously, we don't have distinct lex/parse steps - so it is basically a 'fused lexer' or 'scannerless parser' + + #It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? + + #A possible alternative more structured approach might be to use a PEG (Parsing Expression Grammar) + + + variable is_parsing 0 ;#whether we are in the middle of parsing tomlish text + + variable state + # states: + # table-space, itable-space, array-space + # value-expected, keyval-syntax, + # quoted-key, squoted-key + # string-state, literal-state, multistring... + # + # notes: + # only the -space states are also 'spaces' ie a container which is pushed/popped on the spacestack + + # + # value-expected - we also allow for leading whitespace in this state, but once a value is returned we jump to a state based on the containing space. e.g keyval-tail or array-syntax + # + #stateMatrix defines for each state, actions to take for each possible token. + #single-element actions are the name of the next state into which to transition, or a 'POPSPACE' instruction to pop a level off the spacestack and add the data to the parent container. + #dual-element actions are a push instruction and the name of the space to push on the stack. + # - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) + + # -- --- --- --- --- --- + #token/state naming guide + # -- --- --- --- --- --- + #tokens : underscore separated or bare name e.g newline, start_quote, start_squote + #private tokens: always have a leading underscore (These are private 'temporary state' tokens that are never returned as actual tokens e.g _start_squote_sequence + #states : always contain at least one dash e.g err-state, table-space + #instructions + # -- --- --- --- --- --- + + + #stateMatrix dict of elements mapping current state to next state based on returned tokens + # current-state {token-encountered next-state ... } + # where next-state can be a 1 or 2 element list. + #If 2 element - the first item is an instruction (ucase) + #If 1 element - it is either a lowercase dashed state name or an ucase instruction + #e.g {PUSHSPACE } or POPSPACE or SAMESPACE + + + #SAMESPACE - got to same space as parent without popping a level, but has it's own autotransition lookup - strange concept - review usecases + + variable stateMatrix + set stateMatrix [dict create] + + #xxx-space vs xxx-syntax inadequately documented - TODO + + # --------------------------------------------------------------------------------------------------------------# + # incomplete example of some state starting at table-space + # --------------------------------------------------------------------------------------------------------------# + # ( = -> value-expected) + # keyval-syntax (popped -> keyval-space -> keyval-tail) (autotransition on pop) + # keyval-space (autotransition on push ^) + # table-space (barekey^) (startdquote -> dquoted-key ^) + # --------------------------------------------------------------------------------------------------------------# + + dict set stateMatrix\ + table-space { + bom "table-space"\ + whitespace "table-space"\ + newline "table-space"\ + barekey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + squotedkey {PUSHSPACE "keyval-space" state "keyval-syntax" note ""}\ + dquotedkey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + XXXstartquote "quoted-key"\ + XXXstartsquote "squoted-key"\ + comment "table-space"\ + starttablename "tablename-state"\ + starttablearrayname "tablearrayname-state"\ + startmultiquote "err-state"\ + endquote "err-state"\ + comma "err-state"\ + eof "end-state"\ + equal "err-state"\ + cr "err-lonecr"\ + } + + #itable-space/ curly-syntax : itables + dict set stateMatrix\ + itable-space {\ + whitespace "itable-space"\ + newline "itable-space"\ + barekey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + dquotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + endinlinetable "POPSPACE"\ + XXXstartquote "quoted-key"\ + XXXstartsquote {TOSTATE "squoted-key" comment "jn-testing"}\ + comma "err-state"\ + comment "itable-space"\ + eof "err-state"\ + } + #squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-space starttok {squote_seq "'"}} + + + dict set stateMatrix\ + keyval-space {\ + whitespace "keyval-syntax"\ + equal "keyval-value-expected"\ + } + + # ' = ' portion of keyval + dict set stateMatrix\ + keyval-syntax {\ + whitespace "keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "keyval-value-expected"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + #### + dict set stateMatrix\ + keyval-value-expected {\ + whitespace "keyval-value-expected"\ + untyped_value {TOSTATE "keyval-tail" note ""}\ + squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate keyval-value-expected starttok {squote_seq "'"}}\ + startquote {TOSTATE "string-state" returnstate keyval-tail}\ + startmultiquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + startsquote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + double_squote {TOSTATE "keyval-tail" note "empty literal received when double squote occurs"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + } + #squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate keyval-process-leading-squotes starttok {squote_seq "'"}} + dict set stateMatrix\ + leading-squote-space {\ + squote_seq "POPSPACE"\ + } + #dict set stateMatrix\ + # keyval-process-leading-squotes {\ + # startsquote "literal-state"\ + # triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + # } + + dict set stateMatrix\ + keyval-tail {\ + whitespace "keyval-tail"\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + dict set stateMatrix\ + itable-keyval-syntax {\ + whitespace "itable-keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "itable-keyval-value-expected"\ + newline "err-state"\ + eof "err-state"\ + } + dict set stateMatrix\ + itable-keyval-value-expected {\ + whitespace "itable-keyval-value-expected"\ + untyped_value {TOSTATE "itable-val-tail" note ""}\ + squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-keyval-value-expected starttok {squote_seq "'"}}\ + startquote {TOSTATE "string-state" returnstate itable-val-tail}\ + startmultiquote {PUSHSPACE "multistring-space" returnstate itable-val-tail}\ + startsquote {TOSTATE "literal-state" returnstate itable-val-tail note "usual way a literal is triggered"}\ + double_squote {TOSTATE "itable-val-tail" note "empty literal received when double squote occurs"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate itable-val-tail}\ + startinlinetable {PUSHSPACE "itable-space" returnstate itable-val-tail}\ + startarray {PUSHSPACE "array-space" returnstate itable-val-tail}\ + } + dict set stateMatrix\ + itable-keyval-space {\ + whitespace "itable-keyval-syntax"\ + equal {TOSTATE "itable-keyval-value-expected" note "required"}\ + } + + dict set stateMatrix\ + itable-val-tail {\ + whitespace "itable-val-tail"\ + endinlinetable "POPSPACE"\ + comma "POPSPACE"\ + XXXnewline {TOSTATE "itable-val-tail" note "itable-space ??"}\ + newline "POPSPACE"\ + comment "itable-val-tail"\ + eof "err-state"\ + } + #dict set stateMatrix\ + # itable-quoted-key {\ + # whitespace "NA"\ + # itablequotedkey {PUSHSPACE "itable-keyval-space"}\ + # newline "err-state"\ + # endquote "itable-keyval-syntax"\ + # } + #dict set stateMatrix\ + # itable-squoted-key {\ + # whitespace "NA"\ + # itablesquotedkey {PUSHSPACE "itable-keyval-space"}\ + # newline "err-state"\ + # endsquote "itable-keyval-syntax"\ + # } + + + + + + dict set stateMatrix\ + value-expected {\ + whitespace "value-expected"\ + untyped_value {"SAMESPACE" "" replay untyped_value}\ + startquote "string-state"\ + startsquote "literal-state"\ + startmultiquote {PUSHSPACE "multistring-space"}\ + triple_squote {PUSHSPACE "multiliteral-space"}\ + startinlinetable {PUSHSPACE itable-space}\ + startarray {PUSHSPACE array-space}\ + comment "err-state-value-expected-got-comment"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + + #dottedkey-space is not (currently) used within [tablename] or [[tablearrayname]] + #it is for keyval ie x.y.z = value + + #this is the state after dot + #we are expecting a complete key token or whitespace + #(initial entry to the space is by one of the keys - which will immediately go to dottedkey-space-tail) + dict set stateMatrix\ + dottedkey-space {\ + whitespace "dottedkey-space"\ + dotsep "err-state"\ + barekey "dottedkey-space-tail"\ + squotedkey "dottedkey-space-tail"\ + dquotedkey "dottedkey-space-tail"\ + newline "err-state"\ + comma "err-state"\ + comment "err-state"\ + equal "err-state"\ + } + #dottedkeyend "POPSPACE" + #equal "POPSPACE"\ + + #jmn 2025 + #we have 1 or more dottedkeys so far - need dotsep to add more, whitespace to maintain, equal to pop + dict set stateMatrix\ + dottedkey-space-tail {\ + whitespace "dottedkey-space-tail" + dotsep "dottedkey-space" + equal "POPSPACE"\ + } + + #-------------------------------------------------------------------------- + #scratch area + #from_toml {x=1} + # barekey tok + # table-space PUSHSPACE keyval-space state keyval-syntax + # + + + #-------------------------------------------------------------------------- + + + #REVIEW + #toml spec looks like heading towards allowing newlines within inline tables + #https://github.com/toml-lang/toml/issues/781 + + #2025 - appears to be valid for 1.1 - which we are targeting. + #https://github.com/toml-lang/toml/blob/main/toml.md#inline-table + + #JMN2025 + #dict set stateMatrix\ + # curly-syntax {\ + # whitespace "curly-syntax"\ + # newline "curly-syntax"\ + # barekey {PUSHSPACE "itable-keyval-space"}\ + # itablequotedkey "itable-keyval-space"\ + # endinlinetable "POPSPACE"\ + # startquote "itable-quoted-key"\ + # comma "itable-space"\ + # comment "itable-space"\ + # eof "err-state"\ + # } + #review comment "err-state" vs comment "itable-space" - see if TOML 1.1 comes out and allows comments in multiline ITABLES + #We currently allow multiline ITABLES (also with comments) in the tokenizer. + #if we want to disallow as per TOML 1.0 - we should do so when attempting to get structure? + + + #JMN REVIEW + dict set stateMatrix\ + array-space {\ + whitespace "array-space"\ + newline "array-space"\ + untyped_value "SAMESPACE"\ + startarray {PUSHSPACE "array-space"}\ + endarray "POPSPACE"\ + startmultiquote {PUSHSPACE multistring-space}\ + startinlinetable {PUSHSPACE itable-space}\ + startquote "string-state"\ + startsquote "literal-state"\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax note "seems ok 2024"}\ + comma "array-space"\ + comment "array-space"\ + eof "err-state-array-space-got-eof"\ + } + dict set stateMatrix\ + array-syntax {\ + whitespace "array-syntax"\ + newline "array-syntax"\ + untyped_value "SAMESPACE"\ + startarray {PUSHSPACE array-space}\ + endarray "POPSPACE"\ + startmultiquote {PUSHSPACE multistring-space}\ + startquote "string-state"\ + startsquote "literal-state"\ + comma "array-space"\ + comment "err-state"\ + } + + + + #quoted-key & squoted-key need to PUSHSPACE from own token to keyval-space + dict set stateMatrix\ + quoted-key {\ + whitespace "NA"\ + dquotedkey {PUSHSPACE "keyval-space"}\ + newline "err-state"\ + endquote "keyval-syntax"\ + } + + + #review + dict set stateMatrix\ + dquoted-key {\ + whitespace "NA"\ + dquotedkey "dquoted-key"\ + newline "err-state"\ + } + dict set stateMatrix\ + squoted-key {\ + whitespace "NA"\ + squotedkey "squoted-key"\ + newline "err-state"\ + } + # endsquote {PUSHSPACE "keyval-space"} + + dict set stateMatrix\ + string-state {\ + whitespace "NA"\ + string "string-state"\ + endquote "SAMESPACE"\ + newline "err-state"\ + eof "err-state"\ + } + dict set stateMatrix\ + literal-state {\ + whitespace "NA"\ + literal "literal-state"\ + endsquote "SAMESPACE"\ + newline "err-state"\ + eof "err-state"\ + } + + + #dict set stateMatrix\ + # stringpart {\ + # continuation "SAMESPACE"\ + # endmultiquote "POPSPACE"\ + # eof "err-state"\ + # } + dict set stateMatrix\ + multistring-space {\ + whitespace "multistring-space"\ + continuation "multistring-space"\ + stringpart "multistring-space"\ + newline "multistring-space"\ + endmultiquote "POPSPACE"\ + eof "err-state"\ + } + + + #only valid subparts are literalpart and newline. other whitespace etc is within literalpart + #todo - treat sole cr as part of literalpart but crlf and lf as newline + dict set stateMatrix\ + multiliteral-space {\ + literalpart "multiliteral-space"\ + newline "multiliteral-space"\ + squote_seq_begin {PUSHSPACE "trailing-squote-space" returnstate multiliteral-space starttok {squote_seq "'"}}\ + triple_squote {POPSPACE note "on popping - we do any necessary concatenation of LITERALPART items due to squote processing"}\ + double_squote {TOSTATE multiliteral-space note "short squote_seq: can occur anywhere in the space e.g emitted at end when 5 squotes occur"}\ + startsquote {TOSTATE multiliteral-space note "short squote_seq: same as double_squote - false alarm"}\ + eof "err-premature-eof-in-multiliteral-space"\ + } + + #trailing because we are looking for possible terminating ''' - but must accept '''' or ''''' and re-integrate the 1st one or 2 extra squotes + dict set stateMatrix\ + trailing-squote-space {\ + squote_seq "POPSPACE"\ + } + + + dict set stateMatrix\ + tablename-state {\ + whitespace "NA"\ + tablename {zeropoppushspace table-space}\ + tablename2 {PUSHSPACE table-space}\ + endtablename "tablename-tail"\ + comma "err-state"\ + newline "err-state"\ + } + dict set stateMatrix\ + tablearrayname-state {\ + whitespace "NA"\ + tablearrayname {zeropoppushspace table-space}\ + tablearrayname2 {PUSHSPACE table-space}\ + endtablearray "tablearrayname-tail"\ + comma "err-state"\ + newline "err-state"\ + } + + dict set stateMatrix\ + tablename-tail {\ + whitespace "tablename-tail"\ + newline "table-space"\ + comment "tablename-tail"\ + eof "end-state"\ + } + dict set stateMatrix\ + tablearrayname-tail {\ + whitespace "tablearrayname-tail"\ + newline "table-space"\ + comment "tablearrayname-tail"\ + eof "end-state"\ + } + dict set stateMatrix\ + end-state {} + + set knowntokens [list] + set knownstates [list] + dict for {state transitions} $stateMatrix { + if {$state ni $knownstates} {lappend knownstates $state} + dict for {tok instructions} $transitions { + if {$tok ni $knowntokens} {lappend knowntokens $tok} + } + } + dict set stateMatrix nostate {} + foreach tok $knowntokens { + dict set stateMatrix nostate $tok "err-nostate-received-token-$tok" + } + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #purpose - debugging? remove? + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #build a list of 'push triggers' from the stateMatrix + # ie tokens which can push a new space onto spacestack + set push_trigger_tokens [list] + tcl::dict::for {s transitions} $stateMatrix { + tcl::dict::for {token transition_to} $transitions { + set instruction [lindex $transition_to 0] + switch -exact -- $instruction { + PUSHSPACE - zeropoppushspace { + if {$token ni $push_trigger_tokens} { + lappend push_trigger_tokens $token + } + } + } + } + } + ::tomlish::log::debug "push_trigger_tokens: $push_trigger_tokens" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + + #This seems hacky... (deprecate in favour of explicit arguments to the instructions in stateMatrix?) + #spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE + + #mainly for the -space states: + #redirect to another state $c based on a state transition from $whatever to $b + # e.g "string {array-space array-syntax}" means when transitioning from string to array-space, jump to array-syntax instead. + #this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' + + #Push to, next + #default first states when we push to these spaces + variable spacePushTransitions { + keyval-space keyval-syntax + itable-keyval-space itable-keyval-syntax + array-space array-space + table-space tablename-state + } + #itable-space itable-space + #Pop to, next + variable spacePopTransitions { + array-space array-syntax + } + #itable-space curly-syntax + #itable-keyval-space itable-val-tail + #review + #we pop to keyval-space from dottedkey-space or from value-expected? we don't always want to go to keyval-tail + #leave it out and make the POPSPACE caller explicitly specify it + #keyval-space keyval-tail + + variable spaceSameTransitions { + array-space array-syntax + } + #itable-space curly-syntax + #itable-keyval-space itable-val-tail + + + variable state_list ;#reset every tomlish::decode::toml + + namespace export tomlish toml + namespace ensemble create + + #goNextState has various side-effects e.g pushes and pops spacestack + #REVIEW - setting nest and v elements here is ugly + #todo - make neater, more single-purpose? + proc goNextState {tokentype tok currentstate} { + variable state + variable nest + variable v + + set prevstate $currentstate + + + variable spacePopTransitions + variable spacePushTransitions + variable spaceSameTransitions + + variable last_space_action "none" + variable last_space_type "none" + variable state_list + + set result "" + set starttok "" + + if {[dict exists $::tomlish::parse::stateMatrix $currentstate $tokentype]} { + set transition_to [dict get $::tomlish::parse::stateMatrix $currentstate $tokentype] + ::tomlish::log::debug "--->> goNextState tokentype:$tokentype tok:$tok currentstate:$currentstate : transition_to = $transition_to" + switch -exact -- [lindex $transition_to 0] { + POPSPACE { + spacestack pop + set parent_info [spacestack peek] + set type [dict get $parent_info type] + set parentspace [dict get $parent_info state] + + set last_space_action "pop" + set last_space_type $type + + if {[dict exists $parent_info returnstate]} { + set next [dict get $parent_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace redirected to stored returnstate $next <<---" + } else { + ### + #review - do away with spacePopTransitions - which although useful to provide a default.. + # - involve error-prone configurations distant to the main state transition configuration in stateMatrix + if {[dict exists $::tomlish::parse::spacePopTransitions $parentspace]} { + set next [dict get $::tomlish::parse::spacePopTransitions $parentspace] + ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace redirected state to $next (spacePopTransitions)<<---" + } else { + set next $parentspace + ::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace<<---" + } + } + set result $next + } + SAMESPACE { + set currentspace_info [spacestack peek] + ::tomlish::log::debug "--->> SAMESPACE got current space entry: $currentspace_info <<<<<" + set type [dict get $currentspace_info type] + set currentspace [dict get $currentspace_info state] + + if {[dict exists $currentspace_info returnstate]} { + set next [dict get $currentspace_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected to stored returnstate $next" + } else { + if {[dict exists $::tomlish::parse::spaceSameTransitions $currentspace]} { + set next [dict get $::tomlish::parse::spaceSameTransitions $currentspace] + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected state to $next (spaceSameTransitions)" + } else { + set next $currentspace + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace" + } + } + set result $next + } + zeropoppushspace { + if {$nest > 0} { + #pop back down to the root level (table-space) + spacestack pop + set parentinfo [spacestack peek] + set type [dict get $parentinfo type] + set target [dict get $parentinfo state] + + set last_space_action "pop" + set last_space_type $type + + #----- + #standard pop + set parentlevel [expr {$nest -1}] + lappend v($parentlevel) [set v($nest)] + incr nest -1 + #----- + } + #re-entrancy + + #set next [list PUSHSPACE [lindex $transition_to 1]] + set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 + #::tomlish::log::notice "goNextState REENTRANCY. calling goNextState $nexttokentype $tokentype" + #set result [::tomlish::parse::goNextState $nexttokentype $tokentype] + ::tomlish::log::debug "--->> zeropoppushspace goNextState REENTRANCY. calling goNextState $nexttokentype $currentstate" + set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] + set result [dict get $transition_info newstate] + } + PUSHSPACE { + set original_target [dict get $transition_to PUSHSPACE] + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + if {[dict exists $transition_to starttok]} { + set starttok [dict get $transition_to starttok] + } + spacestack push [dict create type space state $original_target] + + set last_space_action "push" + set last_space_type "space" + + if {[dict exists $transition_to state]} { + #an explicit state in the pushed space was requested in the stateMatrix - override the spacePushTransition (spacePushTransitions can be deprecated if we require explicitness?) + set next [dict get $transition_to state] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next by explicit 'state' entry" + } else { + #puts $::tomlish::parse::spacePushTransitions + if {[dict exists $::tomlish::parse::spacePushTransitions $original_target]} { + set next [dict get $::tomlish::parse::spacePushTransitions $original_target] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next (spacePushTransitions) " + } else { + set next $original_target + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target" + } + } + set result $next + } + TOSTATE { + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + set result [dict get $transition_to TOSTATE] + } + default { + #simplified version of TOSTATE + set result [lindex $transition_to 0] ;#ignore everything but first word + } + } + } else { + ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" + set result "nostate" + } + lappend state_list [list tokentype $tokentype from $currentstate to $result] + set state $result + ::tomlish::log::notice "--->> STATE TRANSITION tokenType: '$tokentype' tok:$tok triggering '$currentstate' -> '$result' last_space_action:$last_space_action " + return [dict create prevstate $prevstate newstate $result space_action $last_space_action starttok $starttok] + } + + proc report_line {{line ""}} { + variable linenum + variable is_parsing + if {$is_parsing} { + if {$line eq ""} { + set line $linenum + } + return "Line Number: $line" + } else { + #not in the middle of parsing tomlish text - return nothing. + return "" + } + } + + #produce a *slightly* more readable string rep of the nest for puts etc. + proc nest_pretty1 {list} { + set prettier "{" + + foreach el $list { + if { [lindex $el 0] eq "NEWLINE"} { + append prettier "[list $el]\n" + } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY DQKEY SQKEY TABLE ARRAY})} { + append prettier [nest_pretty1 $el] + } else { + append prettier "[list $el] " + } + } + append prettier "}" + return $prettier + } + + proc set_tokenType {t} { + variable tokenType + variable tokenType_list + if {![info exists tokenType]} { + set tokenType "" + } + lappend tokenType_list $t + set tokenType $t + } + + proc switch_tokenType {t} { + variable tokenType + variable tokenType_list + lset tokenType_list end $t + set tokenType $t + } + + proc get_tokenType {} { + variable tokenType + return $tokenType + } + + proc _shortcircuit_startquotesequence {} { + variable tok + variable i + set toklen [tcl::string::length $tok] + if {$toklen == 1} { + set_tokenType "startquote" + incr i -1 + return -level 2 1 + } elseif {$toklen == 2} { + puts stderr "_shortcircuit_startquotesequence toklen 2" + set_tokenType "startquote" + set tok "\"" + incr i -2 + return -level 2 1 + } + } + + proc get_token_waiting {} { + variable token_waiting + return [lindex $token_waiting 0] + } + proc clear_token_waiting {} { + variable token_waiting + set token_waiting [list] + } + + #token_waiting is a list - but our standard case is to have only one + #in certain circumstances such as near eof we may have 2 + #the set_token_waiting function only allows setting when there is not already one waiting. + #we want to catch cases of inadvertently trying to set multiple + # - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. + proc set_token_waiting {args} { + if {[llength $args] %2 != 0} { + error "tomlish set_token_waiting must have args of form: type value complete 0|1" + } + variable token_waiting + + if {[llength $token_waiting] && [dict get [lindex $token_waiting end] type] ne "eof"} { + #tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another + #we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context + #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it + set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" + append err \n " - cannot add token_waiting: $args" + error $err + #set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] + #set token_waiting [list] + } + + set waiting [dict create] + dict for {k v} $args { + switch -exact $k { + type - complete { + dict set waiting $k $v + } + value { + dict set waiting tok $v + } + startindex { + dict set waiting startindex $v + } + default { + error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" + } + } + } + if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { + error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" + } + if {![llength $token_waiting]} { + set token_waiting [list $waiting] + } else { + #an extra sanity-check that we don't have more than just the eof.. + if {[llength $token_waiting] > 1} { + set err "tomlish Unexpected. Existing token_waiting count > 1.\n" + foreach tw $token_waiting { + append err " $tw" \n + } + append err " - cannot add token_waiting: $waiting" + error $err + } + #last entry must be a waiting eof + set token_waiting [list $waiting [lindex $token_waiting end]] + } + return + } + + #returns 0 or 1 + #tomlish::parse::tok + #we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag + # - the possible benefit is being able to more easily process in arbitrarily split chunks (although we would still have to watch crlf splitting ?) + # - interactive use? + + proc tok {s} { + variable nest + variable v + variable i + variable tok + variable type ;#character type + variable state ;#FSM + + + variable tokenType + variable tokenType_list + + + variable endToken + + variable lastChar + + variable braceCount + variable bracketCount + + + #------------------------------ + #Previous run found another (presumably single-char) token + #The normal case is for there to be only one dict in the list + #multiple is an exception - primarily for eof + variable token_waiting + if {[llength $token_waiting]} { + set waiting [lindex $token_waiting 0] + + set tokenType [dict get $waiting type] + set tok [dict get $waiting tok] + #todo: dict get $token_waiting complete + set token_waiting [lrange $token_waiting 1 end] + return 1 + } + #------------------------------ + + set resultlist [list] + set sLen [tcl::string::length $s] + + set slash_active 0 + set quote 0 + set c "" + set multi_dquote "" + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $s [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $s $i] + set cindex $i + set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] + tomlish::log::debug "- tokloop char <$ctest> index $i tokenType:$tokenType tok:<$tok>" + #puts "got char $c during tokenType '$tokenType'" + incr i ;#must incr here because we do returns inside the loop + + switch -exact -- $ctest { + # { + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {$had_slash} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + barekey { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" + } + whitespace { + # hash marks end of whitespace token + #do a return for the whitespace, set token_waiting + #set_token_waiting type comment value "" complete 1 + incr i -1 ;#leave comment for next run + return 1 + } + untyped_value { + #REVIEW! the spec isn't clear.. is whitespace after an int,bool etc required before comment? + #we will accept a comment marker as an immediate terminator of the untyped_value. + incr i -1 + return 1 + } + starttablename - starttablearrayname { + #fix! + error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out + append tok $c + } + default { + #dquotedkey, itablequotedkey, string,literal, multistring + append tok $c + } + } + } else { + switch -- $state { + multistring-space { + set_tokenType stringpart + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes#" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "#" + } + default { + #start of token if we're not in a token + set_tokenType comment + set tok "" ;#The hash is not part of the comment data + } + } + } + } + lc { + #left curly brace + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + starttablename - starttablearrayname { + #*bare* tablename can only contain letters,digits underscores + error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #valid in quoted parts + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + switch -exact -- $state { + itable-keyval-value-expected - keyval-value-expected - value-expected { + #switch last key to tablename?? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + array-space - array-syntax { + #nested anonymous inline table + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\{" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\{" + } + default { + error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" + } + } + } + + } + rc { + #right curly brace + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey - comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + starttablename - tablename { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endinlinetable value "" complete 1 startindex $cindex + return 1 + } + starttablearrayname - tablearrayname { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + #end any other token + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + value-expected { + #invalid - but allow parser statemachine to report it. + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-space { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname-state problem" + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + #invalid + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + XXXcurly-syntax { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-val-tail { + set_tokenType "endinlinetable" + set tok "" + #we need to pop the keyval - and then reprocess to pop the inlinetable - so we incr -1 + incr i -1 + return 1 + } + itable-keyval-syntax { + error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\}" + } + multiliteral-space { + set_tokenType "literalpart" ; #review + set tok "\}" + } + default { + #JMN2024b keyval-tail? + error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" + } + } + } + + } + lb { + #left square bracket + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + starttablename { + #change the tokenType + switch_tokenType "starttablearrayname" + set tok "" ;#no output into the tomlish list for this token + #any following whitespace is part of the tablearrayname, so return now + return 1 + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + #append tok "\\[" + append tok {\[} + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + #invalid at this point - state machine should disallow table -> starttablearrayname + set_token_waiting type starttablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "\[" + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + keyval-value-expected - itable-keyval-value-expected - value-expected { + set_tokenType "startarray" + set tok "\[" + return 1 + } + table-space { + #table name + #assume it's a single bracket - but we need to wait for non-bracket to confirm it's not a tablearray + #note that a starttablearrayname token may contain whitespace between the brackets + # e.g \[ \[ + set_tokenType "starttablename" + set tok "" ;#there is no output into the tomlish list for this token + } + array-space - array-syntax { + #nested array? + set_tokenType "startarray" + set tok "\[" + return 1 + #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\[" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\[" + } + itable-space { + #handle state just to give specific error msg + error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[\] syntax. [tomlish::parse::report_line]" + } + default { + error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + rb { + #right square bracket + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + #???? + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } else { + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablename value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + tablearraynames { + #todo? + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + value-expected { + #invalid - but allow parser statemachine to report it. + set_tokenType "endarray" + set tok "\]" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endarray" + set tok "\]" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endtablename" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname problem" + set_tokenType "endtablearray" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + set_tokenType "endarray" + set tok "\]" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "$dquotes\]" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\]" + } + default { + error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + bsl { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + #backslash + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + #end whitespace token + incr i -1 ;#reprocess bsl in next run + return 1 + } else { + error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" + } + } + literal - literalpart - squotedkey { + #never need to set slash_active true when in single quoted tokens + append tok "\\" + set slash_active 0 + } + XXXitablesquotedkey { + } + string - dquotedkey - itablequotedkey - comment { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + stringpart { + if {$slash_active} { + #assert - quotes empty - or we wouldn't have slash_active + set slash_active 0 + append tok "\\\\" + } else { + append tok $dquotes + set slash_active 1 + } + } + starttablename - starttablearrayname { + error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" + } + tablename - tablearrayname { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + barekey { + error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" + } + default { + error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$slash_active} { + set_tokenType "stringpart" + set tok "\\\\" + set slash_active 0 + } else { + if {$dquotes ne ""} { + set_tokenType "stringpart" + set tok $dquotes + } + set slash_active 1 + } + } + multiliteral-space { + #nothing can be escaped in multiliteral-space - not even squotes (?) review + set_tokenType "literalpart" + set tok "\\" + } + default { + error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" + } + } + } + } + sq { + #single quote + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + #short squote_seq tokens are returned if active during any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + switch -- $state { + leading-squote-space { + append tok $c + if {$existingtoklen > 2} { + error "tomlish tok error: squote_seq unexpected length $existingtoklen when another received" + } elseif {$existingtoklen == 2} { + return 1 ;#return tok ''' + } + } + trailing-squote-space { + append tok $c + if {$existingtoklen == 4} { + #maxlen to be an squote_seq is multisquote + 2 = 5 + #return tok ''''' + return 1 + } + } + default { + error "tomlish tok error: squote_seq in unexpected state '$state' - expected leading-squote-space or trailing-squote-space" + } + } + } + whitespace { + #end whitespace + incr i -1 ;#reprocess sq + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + #temp token creatable only during value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + append tok $c + } + 2 { + #switch? + append tok $c + set_tokenType triple_squote + return 1 + } + default { + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" + } + } + } + literal { + #slash_active always false + #terminate the literal + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + literalpart { + #ended by ''' - but final could be '''' or ''''' (up to 2 squotes allowed directly before ending triple squote sequence) + #todo + # idea: end this literalpart (possibly 'temporarily') + # let the sq be reprocessed in the multiliteral-space to push an end-multiliteral-sequence to state stack + # upon popping end-multiliteral-sequence - stitch quotes back into this literalpart's token (if either too short - or a long ending sequence as shown above) + incr i -1 ;#throw the "'" back to loop - will be added to an squote_seq token for later processing + return 1 + } + XXXitablesquotedkey { + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + squotedkey { + ### + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + starttablename - starttablearrayname { + #!!! + incr i -1 + return 1 + } + tablename - tablearrayname { + append tok $c + } + barekey { + #not clear why o'shennanigan shouldn't be a legal barekey - but it seems not to be. + error "tomlish Unexpected single quote during barekey. [tomlish::parse::report_line]" + } + default { + append tok $c + } + } + } else { + switch -exact -- $state { + value-expected - array-space { + set_tokenType "_start_squote_sequence" + set tok "'" + } + itable-keyval-value-expected - keyval-value-expected { + set_tokenType "squote_seq_begin" + set tok "'" + return 1 + } + table-space { + #tests: squotedkey.test + set_tokenType "squotedkey" + set tok "" + } + itable-space { + #tests: squotedkey_itable.test + set_tokenType "squotedkey" + set tok "" + } + XXXitable-space { + #future - could there be multiline keys? + #this would allow arbitrary tcl dicts to be stored in toml + #probably unlikely - as it's perhaps not very 'minimal' or ergonomic for config files + set_tokenType "squote_seq_begin" + set tok "'" + return 1 + } + tablename-state { + #first char in tablename-state/tablearrayname-state + set_tokenType tablename + append tok "'" + } + tablearrayname-state { + set_tokenType tablearrayname + append tok "'" + } + literal-state { + tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?" + set_tokenType literal + incr -1 + return 1 + } + multistring-space { + error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" + } + multiliteral-space { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up an squote_seq to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "squote_seq_begin" + set tok "'" + return 1 + } + dottedkey-space { + set_tokenType squotedkey + } + default { + error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" + } + } + } + + } + dq { + #double quote + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + set toklen [tcl::string::length $tok] + if {$toklen == 1} { + append tok $c + } elseif {$toklen == 2} { + append tok $c + #switch vs set? + set_tokenType "startmultiquote" + return 1 + } else { + error "tomlish unexpected token length $toklen in 'startquotesequence'" + } + } + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + set_tokenType "startsquote" + incr i -1 + return 1 + } + 2 { + set_tokenType "startsquote" + incr i -2 + return 1 + } + default { + error "tomlish unexpected _start_squote_sequence length $toklen" + } + } + } + literal - literalpart { + append tok $c + } + string { + if {$had_slash} { + append tok "\\" $c + } else { + #unescaped quote always terminates a string? + set_token_waiting type endquote value "\"" complete 1 startindex $cindex + return 1 + } + } + stringpart { + #sub element of multistring + if {$had_slash} { + append tok "\\" $c + } else { + #incr i -1 + + if {$multi_dquote eq "\"\""} { + set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex -2}] + set multi_dquote "" + return 1 + } else { + append multi_dquote "\"" + } + } + } + whitespace { + switch -exact -- $state { + multistring-space { + #REVIEW + if {$had_slash} { + incr i -2 + return 1 + } else { + switch -- [tcl::string::length $multi_dquote] { + 2 { + set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex-2}] + set multi_dquote "" + return 1 + } + 1 { + incr i -2 + return 1 + } + 0 { + incr i -1 + return 1 + } + } + } + } + keyval-value-expected - value-expected { + #end whitespace token and reprocess + incr i -1 + return 1 + + #if {$multi_dquote eq "\"\""} { + # set_token_waiting type startmultiquote value "\"\"\"" complete 1 + # set multi_dquote "" + # return 1 + #} else { + # #end whitespace token and reprocess + # incr i -1 + # return 1 + #} + } + table-space - itable-space { + incr i -1 + return 1 + } + default { + set_token_waiting type startquote value "\"" complete 1 startindex $cindex + return 1 + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + XXXdquotedkey - XXXitablequotedkey { + if {$had_slash} { + append tok "\\" + append tok $c + } else { + set_token_waiting type endquote value "\"" complete 1 startindex $cindex + return 1 + } + } + dquotedkey { + ### + if {$had_slash} { + append tok "\\" + append tok $c + } else { + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + } + squotedkey { + append tok $c + } + tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + incr i -1 ;## + return 1 + } + default { + error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + #$slash_active not relevant when no tokenType + #token is string only if we're expecting a value at this point + switch -exact -- $state { + keyval-value-expected - value-expected - array-space { + #!? start looking for possible multistartquote + #set_tokenType startquote + #set tok $c + #return 1 + set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote + set tok $c + } + itable-keyval-value-expected { + #JMN 2025 - review + set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote + set tok $c + } + multistring-space { + #TODO - had_slash!!! + #REVIEW + if {$had_slash} { + set_tokenType "stringpart" + set tok "\\\"" + set multi_dquote "" + } else { + if {$multi_dquote eq "\"\""} { + tomlish::log::debug "- tokloop char dq ---> endmultiquote" + set_tokenType "endmultiquote" + set tok "\"\"\"" + return 1 + #set_token_waiting type endmultiquote value "\"\"\"" complete 1 + #set multi_dquote "" + #return 1 + } else { + append multi_dquote "\"" + } + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\"" + } + XXXtable-space { + set_tokenType "startquote" + set tok $c + return 1 + } + XXXitable-space { + set_tokenType "startquote" + set tok $c + } + table-space - itable-space { + set_tokenType "dquotedkey" + set tok "" + } + tablename-state { + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + dottedkey-space { + set_tokenType dquotedkey + set tok "" + + #only if complex keys become a thing + #set_tokenType dquote_seq_begin + #set tok $c + } + default { + error "tomlish Unexpected quote during state '$state' [tomlish::parse::report_line]" + } + } + } + } + = { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart - squotedkey { + #assertion had_slash 0, multi_dquote "" + append tok $c + } + string - comment - dquotedkey - itablequotedkey { + #for these tokenTypes an = is just data. + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + whitespace { + if {$state eq "multistring-space"} { + set backlen [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backlen + return 1 + } else { + set_token_waiting type equal value = complete 1 startindex $cindex + return 1 + } + } + barekey { + #set_token_waiting type equal value = complete 1 + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out + append tok $c + } + default { + error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok ${dquotes}= + } + multiliteral-space { + set_tokenType "literalpart" + set tok "=" + } + dottedkey-space { + set_tokenType "equal" + set tok "=" + return 1 + } + default { + set_tokenType "equal" + set tok = + return 1 + } + } + } + } + cr { + #REVIEW! + set dquotes $multi_dquote + set multi_dquote "" ;#!! + # \r carriage return + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #we have received a double cr + ::tomlish::log::warn "double cr - will generate cr token. needs testing" + set_tokenType "cr" ;#lone cr token will generally raise an error - but let state machine handle it + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal { + append tok $c + } + literalpart { + #part of MLL string (multi-line literal string) + #we need to split out crlf as a separate NEWLINE to be consistent + ::tomlish::log::warn "literalpart ended by cr - needs testing" + #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space + incr i -1 + return 1 + } + stringpart { + #stringpart is a part of MLB string (multi-line basic string) + #throw back the cr - if followed by lf it will become a {NEWLINE crlf} entry within the MULTISTRING list (e.g between STRINGPART entries) + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #could in theory be valid in quoted part of name + #review - might be better just to disallow here + append tok $c + } + whitespace { + #it should technically be part of whitespace if not followed by lf + #but outside of values we are also free to map it to be another NEWLINE instead? REVIEW + incr i -1 + return 1 + } + untyped_value { + incr i -1 + return 1 + } + default { + #!todo - error out if cr inappropriate for tokenType + append tok $c + } + } + } else { + #lf may be appended if next + #review - lone cr as newline? - this is uncommon - but so is lone cr in a string(?) + set_tokenType "newline" + set tok cr + } + } + lf { + # \n newline + set dquotes $multi_dquote + set multi_dquote "" ;#!! + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #review + #this lf is the trailing part of a crlf + append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal { + #nl is not allowed *within* a literal - require multiliteral syntax for any literal containing a newline ''' ''' + #even though we terminate the literal without the closing quote here - the token_waiting newline should trigger a state error + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + literalpart { + #we allow newlines - but store them within the multiliteral as their own element + #This is a legitimate end to the literalpart - but not the whole multiliteral + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + stringpart { + if {$dquotes ne ""} { + append tok $dquotes + incr i -1 + return 1 + } else { + if {$had_slash} { + #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) + set_token_waiting type continuation value \\ complete 1 startindex [expr {$cindex-1}] + incr i -1 + return 1 + } else { + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } + starttablename - tablename - tablearrayname - starttablearrayname { + error "tomlish Character is invalid in $tokenType. [tomlish::parse::report_line]" + } + default { + #newline ends all other tokens. + #note for string: we don't add (raw unescaped) newline to simple string. (must use multi-string for this) + #note for whitespace: + # we will use the convention that \n terminates the current whitespace even if whitespace follows + # ie whitespace is split into separate whitespace tokens at each newline + + #puts "-------------- newline lf during tokenType $tokenType" + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + if {$dquotes ne ""} { + #e.g one or 2 quotes just before nl + set_tokenType "stringpart" + set tok $dquotes + incr i -1 + return 1 + } + set_tokenType "newline" + set tok lf + return 1 + } + } + multiliteral-space { + #assert had_slash 0, multi_dquote "" + set_tokenType "newline" + set tok "lf" + return 1 + } + default { + #ignore slash? error? + set_tokenType "newline" + set tok lf + return 1 + } + } + #if {$had_slash} { + # #CONT directly before newline - allows strings_5_byteequivalent test to pass + # set_tokenType "continuation" + # set tok "\\" + # incr i -1 + # return 1 + #} else { + # set_tokenType newline + # set tok lf + # return 1 + #} + } + } + , { + set dquotes $multi_dquote + set multi_dquote "" + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + comment - tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok , + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + #stringpart can have up to 2 quotes too + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + literal - literalpart - squotedkey { + #assert had_slash always 0, multi_dquote "" + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + set backlen [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backlen + return 1 + } else { + set_token_waiting type comma value "," complete 1 startindex $cindex + return 1 + } + } + default { + set_token_waiting type comma value "," complete 1 startindex $cindex + if {$had_slash} {append tok "\\"} + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "$dquotes," + } + multiliteral-space { + #assert had_slash 0, multi_dquote "" + set_tokenType "literalpart" + set tok "," + } + default { + set_tokenType "comma" + set tok "," + return 1 + } + } + } + } + . { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + comment - untyped_value { + if {$had_slash} {append tok "\\"} + append tok $c + } + string - dquotedkey - itablequotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $dquotes$c + } + literal - literalpart - squotedkey { + #assert had_slash always 0, multi_dquote "" + append tok $c + } + whitespace { + switch -exact -- $state { + multistring-space { + set backchars [expr {[tcl::string::length $dquotes] + 1}] + if {$had_slash} { + incr backchars 1 + } + incr i -$backchars + return 1 + } + xxxdottedkey-space { + incr i -1 + return 1 + } + dottedkey-space-tail { + incr i -1 + return 1 + } + default { + error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" + } + } + } + starttablename - starttablearrayname { + #This would correspond to an empty table name + error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #subtable - split later - review + append tok $c + } + barekey { + #e.g x.y = 1 + #we need to transition the barekey to become a structured table name ??? review + #x is the tablename y is the key + set_token_waiting type dotsep value "." complete 1 startindex $cindex + return 1 + } + default { + error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" + #set_token_waiting type period value . complete 1 + #return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "$dquotes." + } + multiliteral-space { + set_tokenType "literalpart" + set tok "." + } + XXXdottedkey-space { + ### obs? + set_tokenType "dotsep" + set tok "." + return 1 + } + dottedkey-space-tail { + ### + set_tokenType "dotsep" + set tok "." + return 1 + } + default { + set_tokenType "untyped_value" + set tok "." + } + } + } + + } + " " { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + if {[tcl::string::length $tokenType]} { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + barekey { + #todo had_slash - emit token or error + #whitespace is a terminator for bare keys + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + comment { + if {$had_slash} { + append tok "\\" + } + append tok $dquotes$c + } + string - dquotedkey - itablequotedkey { + if {$had_slash} { append tok "\\" } + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + append tok $dquotes + incr i -1 + return 1 + } + } + literal - literalpart - squotedkey { + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + if {$dquotes ne ""} { + #end whitespace token + #go back by the number of quotes plus this space char + set backchars [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backchars + return 1 + } else { + append tok $c + } + } else { + append tok $c + } + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + if {$dquotes ne ""} { + set_tokenType "stringpart" + set tok $dquotes + incr i -1 + return 1 + } + set_tokenType "whitespace" + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + if {$had_slash} { + error "tomlish unexpected backslash [tomlish::parse::report_line]" + } + set_tokenType "whitespace" + append tok $c + } + } + } + } + tab { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out (?review) + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + barekey { + #whitespace is a terminator for bare keys + incr i -1 + #set_token_waiting type whitespace value $c complete 1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + squotedkey { + append tok $c + } + dquotedkey - string - comment - whitespace { + #REVIEW + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + append tok $dquotes + incr i -1 + return 1 + } + } + literal - literalpart { + append tok $c + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearraynames { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + if {$slash_active} { + set slash_active 0 + } + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + if {$dquotes ne ""} { + set_tokenType stringpart + set tok $dquotes + incr i -1 + return 1 + } else { + set_tokenType whitespace + append tok $c + } + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "whitespace" + append tok $c + } + } + } + } + bom { + #BOM (Byte Order Mark) - ignored by token consumer + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + _start_squote_sequence { + #assert - tok will be one or two squotes only + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + literal - literalpart { + append tok $c + } + default { + set_token_waiting type bom value "\uFEFF" complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "bom" + set tok "\uFEFF" + return 1 + } + } + } + } + default { + set dquotes $multi_dquote + set multi_dquote "" ;#!! + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + squote_seq { + incr i -1 + return 1 + } + startquotesequence { + _shortcircuit_startquotesequence + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "startsquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + if {$dquotes ne ""} { + set backlen [expr {[tcl::string::length $dquotes] + 1}] + incr i -$backlen + return 1 + } else { + incr i -1 + return 1 + } + } else { + #review + incr i -1 ;#We don't have a full token to add to the token_waiting dict - so leave this char for next run. + return 1 + } + } + barekey { + if {[tomlish::utils::is_barekey $c]} { + append tok $c + } else { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" + } + } + starttablename - starttablearrayname { + incr i -1 + #allow statemachine to set context for subsequent chars + return 1 + } + stringpart { + append tok $dquotes$c + } + default { + #e.g comment/string/literal/literalpart/untyped_value/starttablename/starttablearrayname/tablename/tablearrayname + append tok $c + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + table-space - itable-space { + #if no currently active token - assume another key value pair + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + XXXcurly-syntax { + puts stderr "curly-syntax - review" + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + multistring-space { + set_tokenType "stringpart" + if {$had_slash} { + #assert - we don't get had_slash and dquotes at same time + set tok \\$c + } else { + set tok $dquotes$c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + tablename-state { + set_tokenType "tablename" + set tok $c + } + tablearrayname-state { + set_tokenType "tablearrayname" + set tok $c + } + dottedkey-space { + set_tokenType barekey + set tok $c + } + default { + #todo - something like ansistring VIEW to show control chars? + set cshow [string map [list \t tab \v vt] $c] + tomlish::log::debug "- tokloop char '$cshow' setting to untyped_value while state:$state [tomlish::parse::report_line]" + set_tokenType "untyped_value" + set tok $c + } + } + } + } + } + + } + + #run out of characters (eof) + if {[tcl::string::length $tokenType]} { + #check for invalid ending tokens + #if {$state eq "err-state"} { + # error "Reached end of data whilst tokenType = '$tokenType'. INVALID" + #} + switch -exact -- $tokenType { + startquotesequence { + set toklen [tcl::string::length $tok] + if {$toklen == 1} { + #invalid + #eof with open string + error "tomlish eof reached without closing quote for string. [tomlish::parse::report_line]" + } elseif {$toklen == 2} { + #valid + #we ended in a double quote, not actually a startquoteseqence - effectively an empty string + switch_tokenType "startquote" + incr i -1 + #set_token_waiting type string value "" complete 1 + return 1 + } + } + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open literal + error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" + } + 2 { + #review + set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] + set_tokenType "literal" + set tok "" + return 1 + } + } + } + newline { + #The only newline token that has still not been returned should have a tok value of "cr" + puts "tomlish eof reached - with incomplete newline token '$tok'" + if {$tok eq "cr"} { + #we convert lone cr to it's own "cr" token elsewhere in the document to allow statemachine to handle it. + #(which it should generally do by not handling it ie raising an error - or emitting an ERROR list in the tomlish) + #if trailing char is a lone cr - we should encode it the same way as elsewhere that is outside of values + # ie as it's own token. + switch_tokenType "cr" + return 1 + } else { + #should be unreachable + error "tomlish eof reached - with invalid newline token. value: $tok" + } + } + } + set_token_waiting type eof value eof complete 1 startindex $i ;#review + return 1 + } else { + ::tomlish::log::debug "- No current tokenType, ran out of characters, setting tokenType to 'eof' [tomlish::parse::report_line]" + set tokenType "eof" + set tok "eof" + } + return 0 + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::parse ---}] +} + +namespace eval tomlish::dict { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} + } + proc is_tomlish_typeval2 {d} { + upvar ::tomlish::tags tags + expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} + } + proc last_tomltype_posn {d} { + set last_simple -1 + set dictposn [expr {[dict size $d] -1}] + foreach k [lreverse [dict keys $d]] { + set dval [dict get $d $k] + if {[is_tomlish_typeval $dval]} { + set last_simple $dictposn + break + } + incr dictposn -1 + } + return $last_simple + } + + + #review + proc name_from_tablestack {tablestack} { + set name "" + foreach tinfo [lrange $tablestack 1 end] { + lassign $tinfo type namepart + switch -- $type { + T { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + I { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + default { + #end at first break in the leading sequence of T & I tablenames + break + } + } + } + return $name + } + +} + +tcl::namespace::eval tomlish::app { + variable applist [list encoder decoder test] + + #*** !doctools + #[subsection {Namespace tomlish::app}] + #[para] + #[list_begin definitions] + + proc decoder {args} { + #*** !doctools + #[call app::[fun decoder] [arg args]] + #[para] read toml on stdin until EOF + #[para] on error - returns non-zero exit code and writes error on stderr + #[para] on success - returns zero exit code and writes JSON encoding of the data on stdout + #[para] This decoder is intended to be compatible with toml-test + + set opts [dict merge [dict create] $args] + #fconfigure stdin -encoding utf-8 + fconfigure stdin -translation binary + #Just slurp it all - presumably we are not handling massive amounts of data on stdin. + # - even if the input is large, we probably don't gain much (aside from possible memory savings?) by attempting to process input as it arrives. + if {[catch { + set toml [read stdin] + }]} { + exit 2 ;#read error + } + try { + set j [::tomlish::toml_to_json $toml] + } on error {em} { + puts stderr "decoding failed: '$em'" + exit 1 + } + puts -nonewline stdout $j + exit 0 + } + + proc encoder {args} { + #*** !doctools + #[call app::[fun encoder] [arg args]] + #[para] read JSON on stdin until EOF + #[para] return non-zero exitcode if JSON data cannot be converted to a valid TOML representation + #[para] return zero exitcode and TOML data on stdout if JSON data can be converted. + #[para] This encoder is intended to be compatible with toml-test + + set opts [dict merge [dict create] $args] + fconfigure stdin -translation binary + if {[catch { + set json [read stdin] + }]} { + exit 2 ;#read error + } + try { + set toml [::tomlish::json_to_toml $json] + } on error {em} { + puts stderr "encoding failed: '$em'" + exit 1 + } + puts -nonewline stdout $toml + exit 0 + } + + proc test {args} { + set opts [dict merge [dict create] $args] + + package require test::tomlish + if {[dict exists $opts -suite]} { + test::tomlish::suite [dict get $opts -suite] + } + test::tomlish::run + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::app ---}] +} + +proc ::tomlish::appnames {} { + set applist [list] + foreach cmd [info commands ::tomlish::app::*] { + lappend applist [namespace tail $cmd] + } + return $applist +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace tomlish::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 tomlish::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +if {$argc > 0} { + puts stderr "argc: $argc args: $argv" + + if {($argc == 1)} { + if {[tcl::string::tolower $argv] in {help -help h -h}} { + puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + exit 0 + } else { + puts stderr "Argument '$argv' not understood. Try -help" + exit 1 + } + } + set opts [dict create] + set opts [dict merge $opts $argv] + + set opts_understood [list -app ] + if {"-app" in [dict keys $opts]} { + #Don't vet the remaining opts - as they are interpreted by each app + } else { + foreach key [dict keys $opts] { + if {$key ni $opts_understood} { + puts stderr "Option '$key' not understood" + exit 1 + } + } + } + if {[dict exists $opts -app]} { + set app [dict get $opts -app] + if {$app ni [tomlish::appnames]} { + puts stderr "app '[dict get $opts -app]' not found" + exit 1 + } + tomlish::app::$app {*}$opts + } +} + +## Ready +package provide tomlish [namespace eval tomlish { + variable pkg tomlish + variable version + set version 1.1.3 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/uuid-1.0.8.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/uuid-1.0.8.tm new file mode 100644 index 00000000..c5cffa67 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/uuid-1.0.8.tm @@ -0,0 +1,246 @@ +# uuid.tcl - Copyright (C) 2004 Pat Thoyts +# +# UUIDs are 128 bit values that attempt to be unique in time and space. +# +# Reference: +# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt +# +# uuid: scheme: +# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html +# +# Usage: uuid::uuid generate +# uuid::uuid equal $idA $idB + +package require Tcl 8.5 9 + +namespace eval uuid { + variable accel + array set accel {critcl 0} + + namespace export uuid + + variable uid + if {![info exists uid]} { + set uid 1 + } + + proc K {a b} {set a} +} + +### +# Optimization +# Caches machine info after the first pass +### + +proc ::uuid::generate_tcl_machinfo {} { + variable machinfo + if {[info exists machinfo]} { + return $machinfo + } + lappend machinfo [clock seconds]; # timestamp + lappend machinfo [clock clicks]; # system incrementing counter + lappend machinfo [info hostname]; # spatial unique id (poor) + lappend machinfo [pid]; # additional entropy + lappend machinfo [array get ::tcl_platform] + + ### + # If we have /dev/urandom just stream 128 bits from that + ### + if {[file exists /dev/urandom]} { + set fin [open /dev/urandom r] + fconfigure $fin -encoding binary + binary scan [read $fin 128] H* machinfo + close $fin + } elseif {[catch {package require nettool}]} { + # More spatial information -- better than hostname. + # bug 1150714: opening a server socket may raise a warning messagebox + # with WinXP firewall, using ipconfig will return all IP addresses + # including ipv6 ones if available. ipconfig is OK on win98+ + if {[string equal $::tcl_platform(platform) "windows"]} { + catch {exec ipconfig} config + lappend machinfo $config + } else { + catch { + set s [socket -server void -myaddr [info hostname] 0] + K [fconfigure $s -sockname] [close $s] + } r + lappend machinfo $r + } + + if {[package provide Tk] != {}} { + lappend machinfo [winfo pointerxy .] + lappend machinfo [winfo id .] + } + } else { + ### + # If the nettool package works on this platform + # use the stream of hardware ids from it + ### + lappend machinfo {*}[::nettool::hwid_list] + } + return $machinfo +} + +# Generates a binary UUID as per the draft spec. We generate a pseudo-random +# type uuid (type 4). See section 3.4 +# +proc ::uuid::generate_tcl {} { + package require md5 2 + variable uid + + set tok [md5::MD5Init] + md5::MD5Update $tok [incr uid]; # package incrementing counter + foreach string [generate_tcl_machinfo] { + md5::MD5Update $tok $string + } + set r [md5::MD5Final $tok] + binary scan $r c* r + + # 3.4: set uuid versioning fields + lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] + lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] + + return [binary format c* $r] +} + +if {[string equal $tcl_platform(platform) "windows"] + && [package provide critcl] != {}} { + namespace eval uuid { + critcl::ccode { + #define WIN32_LEAN_AND_MEAN + #define STRICT + #include + #include + typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); + typedef const unsigned char cu_char; + } + critcl::cproc generate_c {Tcl_Interp* interp} ok { + HRESULT hr = S_OK; + int r = TCL_OK; + UUID uuid = {0}; + HMODULE hLib; + LPFNUUIDCREATE lpfnUuidCreate = NULL; + hLib = LoadLibraryA(("rpcrt4.dll")); + if (hLib) + lpfnUuidCreate = (LPFNUUIDCREATE) + GetProcAddress(hLib, "UuidCreate"); + if (lpfnUuidCreate) { + Tcl_Obj *obj; + lpfnUuidCreate(&uuid); + obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); + Tcl_SetObjResult(interp, obj); + } else { + Tcl_SetResult(interp, "error: failed to create a guid", + TCL_STATIC); + r = TCL_ERROR; + } + return r; + } + } +} + +# Convert a binary uuid into its string representation. +# +proc ::uuid::tostring {uuid} { + binary scan $uuid H* s + foreach {a b} {0 7 8 11 12 15 16 19 20 end} { + append r [string range $s $a $b] - + } + return [string tolower [string trimright $r -]] +} + +# Convert a string representation of a uuid into its binary format. +# +proc ::uuid::fromstring {uuid} { + return [binary format H* [string map {- {}} $uuid]] +} + +# Compare two uuids for equality. +# +proc ::uuid::equal {left right} { + set l [fromstring $left] + set r [fromstring $right] + return [string equal $l $r] +} + +# Call our generate uuid implementation +proc ::uuid::generate {} { + variable accel + if {$accel(critcl)} { + return [generate_c] + } else { + return [generate_tcl] + } +} + +# uuid generate -> string rep of a new uuid +# uuid equal uuid1 uuid2 +# +proc uuid::uuid {cmd args} { + switch -exact -- $cmd { + generate { + if {[llength $args] != 0} { + return -code error "wrong # args:\ + should be \"uuid generate\"" + } + return [tostring [generate]] + } + equal { + if {[llength $args] != 2} { + return -code error "wrong \# args:\ + should be \"uuid equal uuid1 uuid2\"" + } + return [eval [linsert $args 0 equal]] + } + default { + return -code error "bad option \"$cmd\":\ + must be generate or equal" + } + } +} + +# ------------------------------------------------------------------------- + +# LoadAccelerator -- +# +# This package can make use of a number of compiled extensions to +# accelerate the digest computation. This procedure manages the +# use of these extensions within the package. During normal usage +# this should not be called, but the test package manipulates the +# list of enabled accelerators. +# +proc ::uuid::LoadAccelerator {name} { + variable accel + set r 0 + switch -exact -- $name { + critcl { + if {![catch {package require tcllibc}]} { + set r [expr {[info commands ::uuid::generate_c] != {}}] + } + } + default { + return -code error "invalid accelerator package:\ + must be one of [join [array names accel] {, }]" + } + } + set accel($name) $r +} + +# ------------------------------------------------------------------------- + +# Try and load a compiled extension to help. +namespace eval ::uuid { + variable e {} + foreach e {critcl} { + if {[LoadAccelerator $e]} break + } + unset e +} + +package provide uuid 1.0.8 + +# ------------------------------------------------------------------------- +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.11.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/zipper-0.12.tm similarity index 67% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.11.tm rename to src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/zipper-0.12.tm index 2f72c19e1ff3e27507484b1e6fa13f6ddc982b17..1983211c4274a86b312dfaeee4ea996e1b9ac7e1 100644 GIT binary patch delta 2786 zcmai$X*AT09>-@aBO@XvO<7{>4;jkDAjzIWl5CNEXY5)3Pv$X1w!x5X64}R=HG^cC z7|q0F$&x3L?6M}?eeQNn_ndp~{l5CW_@2-2`||Tlf8%D2EEr<%@95?p{8AqL{44-E z0ZK(+tX?|8U*@xeK!SoGkSGWQLU{W+VSJtB!rUD z2`O3R46vp2X$u`(&RWP=L_XeRt}AUltUGw7De|HLFb0p1(zecoQ>agFD)J*3iVPmH z+qjjI=$j9LcqI2|a?S9y*6bOcr0UIG$*-NF+ZTzCy$aZ5|Nq=zmp63m*t7ksFa z(39g(n09tUF%&}-r^bCQRCXV#7n`U|EKu3X6T6*W*;is>EHNhRiuqw8ci@HdEvr$g zhg{2mvEB=CVMiN0$}|n=%6M3w>3-UP7}mQsqr*WBM%h^lu_2uMP{ zGI&dby-qnx{4~n#Stz8H)Xg85yP8`xy*mY1zv;Wak5{qsP1+(gc+S)7^A{dKkUkl# zC`vqZG)DUXyp-3zUi`kld9<2`F6}s&bY2YSyjnXX{YH&%@vJL-tMlR7S5Kt#$p!Grq}KI1{Wa^m&OPXvxo~-&6yYO00e0IBVkc zAu0Ydt@3f?ZSEg4hvQ=Oe9ruku;DFfXa%5B*{E>$7Qf-yGG57AD?KzMw4~A9i;FkS zeazL7k1v;YY0)P{A?H0Z4*w^?(QVcB0=7YLw?<`8UorsAzA!6^4mFfqYx-c17K%zo z7JGOQ92bAQ4$+$033}KVGt%6#>g{e?`K4$HA%GHIkZTj^W`$cS_wG+*TVU)hP67+u zN>x)kSA)ao#31@bc_MMJqjaUMjV!R9x9eivRQxSxZPO()vn_v0Aw+dNKXki1q>*%k zD96acrQ#T2Z^j%I3nBSBa#Q+sf5dz)NA|kFms(qDd>TN=Eo~i=BPadS!#VVJ>wTH) znbmo653pif@8V>P;CsE_q-O_6fQQaXqOAGGqA^9d%C@i@gU59{rbma<2mw{WxUTrF zPcHfx3(c?{iiZO$pmEwkUWk7nhisVI3Ii|Z!}jhhj*tR6UPIy@qamq_erN@O5v?sP zy!Kr+ovIE0lqDA~Cz7P~qPByV7q@*tV$xz`jcypLU;BR2BmfHCb^h^}+AjNA_4RGJZI3>4`CD{2foR z(M3Cww0CHXu5-n;&;C3Mug|b-1w_|0YeMBME*w1VUAh7kGN3tkSk^>`-9j#K0rfWb zE5v5x6Fp9Fxno~gBz82L4&36^K&hCYB?Oi+Iy>5qJ=;acfJx-z95cU8>$3Bd!8zx9 zaWA|QOTV-*-8bl?*rW_TERx=1f zMUZd!>?jWbWRK^s7iKF%PbUtNH# zfLP^RdZE;kD#Q^v&B>8~=!wv5v*OcO->Dks9QK7eM@4dG@7-nlpt_vax<2mJEQtU= z`Jnf%DpI*B6tJiL+z!#ODxX<08>1Qdk#iRqPl0%;p%8eW3cglUeFFClf(1mSI zLRd%P$*jv6;QQzI$CVp;hk{Pbtc=7~jC_ppt15pp>Mj9i6Q4&a+|;y_S}WN>40y$l zPEWhCx(gb=PjD*&oQBzno~d2kINGqV0C&wHioLq>s5$CZ3f&+4F*(I$u+PaY7Be{z z;0v6WV|?i#x1sm7sKMWEq=y^O{eVZ)*hrtc^OlLvkdKN_-MjodmJn&y=GD?%H}XAO zd-v_DX~*3ltquDvJGQ#ejpHXy)h3Rc;ym6>4LifT$7XN)@16o0lx#iT8>2d(SE;qQ zv=&y{1QIcp1&z%rN8-wa?;p5~dgt1$UKj$S_%AlRlL<^V;2ri{PvK&_B-ao#SGloe za(_4}k|LOYcD#$Gt1PJYsiv#%6+v>TDcO2E*t&7lNPQXExt zV?Jl=$SsYsL_1ys;-F0g^YH0xH!4|2s!@k*hwoTf2%H!n(WA)j{W#RRN_HB+O7<1SwnDHiy z-)`FWPO#I8d5s@~KjG=is~|#Q(G~z+G&lrZ6r8^3~Qyb7-o64|UV&*kpGg98$z z1v2TE&DCO!GHYv@->SLl9Vv3Ts2$fcKDHzya4UV;r++L24#SQ@6|<-xCyu0xH&bv! zPh8t^9AiEHjSbkLs3rjHN#z+&94wJBm+}tQ?(&W-{t}>?MK|8wBmQB!4eXzm6l$H? zBhKy5=r~KDZ=R{VA11%K-+;BmlXUr=^=#%xC?l5$!FM1KdHDBhPFLPv{}gxhg;rGt z@remsq}-V^-#T$Lb+VS70QWf;%aDR^o=l4s;=%gV?#p$O_=ma%-Rc?G1Qn-L)CM)@ zvIJX(P$|Ci{xj>1L{>XhCR+8Re$O}V)0}(8FvYlFj|t6jTZQM{ zrQ_PISL^zCKBFT+DP*q4_GC0)>*lF>OTrQ|Q{A|emghxoF&cwjI7M60CHcefc&Hnk zDy(JR12v@3^vsIt9OP$qrcDf)S@`}^yAvR_K#FWhdF%@s7$gt!Vg`XkK&=16_%532 zXlmcmIX(u1Kriz|hQI(H=%1kfW{!V-_$B|}BTWp!O#kNnGVEWwenEjg{pF|s;Boz@ Pn5G>dgdpo2f3N-x$*ems delta 2187 zcma);X*AT09>>Qr${G=}jcgG^)@0wa4U@5xZJ4rVixB@bkBcmYvhR^hWM7*iV+oJt z!H}_JX~vA~vNt^4d(S=h-gBOF&;7mnzWANb`M&#ncg%~8Yh`HYP~LtG3N)p>!1?na zOA9Lp8idSi>vJGbGbacn0s?_V{qK7Q-uHw?dItu21w*gP%FE0BN0trsueSFMnNi`U zZny^dj_)Bw?5x(3GYCiNp%n!ID8(7e%Bo1=i|KGgnd#$nL7TG=D=v>kqCW z4%=zMSYaTUH2OlaqH9sO-FClJbVv;h->KAiBT|_6a-%MRS&piX<^fmZIeV_Xdf=kb zDKY828#hb$a<~j$4ArkfUM)2^R|S_!b+jMD_omWAf^BKhOw~WPy-F%bX)nazW?|qK z=b~aBdjQounO^$$PIcOw+2=1Bh_SfhjI&lMy>=UB!OwY%nEL1$VAb4Q4lmp|S=_|1 z9?s@VJ?qRE_=$8qS$bzF2E*!r^bg_&{4n|b zin+qi*)25-dfIp?JYn%?H4VL_sVTdfC^YJ4!mCJk0e`=7oEJrAuU=#P`-CSuWVWdQ zXA)3AbIAX8IXd~Z($jH`7&i&1PS5$MH#|ZreMRJlx_yj-fMp+qd{_b9Lowe%^ECi^ zBYrna3Tde0@O z5>^~M`m7PMHj}xR*D&u=4d2vh_cE`mo8yy@{Ur-CYk&KwsYgq@wSGR^ku96Uhc!bM zKmGfV6h^}b$u~G}oZ1-YsrrSZ>r3(l!hDqdd{=%=$Lp;h`1Rf61F2&y<02R^TZ;sS z=FM_cb+@3GZ?o00*tO`y)aQHh;(0u06Uz0So<=;{wifgZ%m{KcCA?@k zz1HSQL_GYBk50clQk3#kd0sPfdxHv4%1TJ|#83y`7k1e=xevBc zwt23ObMgX{z2&of9gND!NlMyb$|_uw!Ie|E4!P6&L58($cR3E?NI-i1*nuw6_(@5( zi90Vsj;XvR?JTu*GFt!4XJN3DrZ7BzeUwFlp-?nlBW)9QyMJ{Y0$}-PSsCs3ASbxf zh2UVDU81032iTguq$r{)b4!b?j?yEu@J{{NAaF_n3ifz$Qko0(>kH5w_H- zBpm--Njrt>^n%)1c=Tqwkmg7s8#`e1IdbZ#Bf5$y>*Ik=EJSWomXb*cng;rR6eC6l zgEO*U#V+1d`zzN?Y> zhrZgm-t_&g!qW)x9L**};Ve67y;IjJ8aeSyuO``LYN_L7Ac8$2(I9XFal#X`1l)QZU(5-0dgaku6^ApYX-#u(!h>a9<%bfh;CcDpi z6nFPaIMw{&6$VrkT%RJ4^1 z^xQ!X6i2Pa3~ei$k{@XZZ8q5i3)c7BA6Qkz_KHg#(w`p*IJ+FuAA>os_u0?!HHxc+Q3K)_*a5a=jPpRbfj{ql zUSH?6ng`a?F5+Kx#38=vg!^c^9d=2l8(LN2R|MV3P(_r-{ic~k;vvbZg0Ma;f;t1i z&FJX4K%ifW)(GvBslddS57U4^esmzvmH(+|St~OO8@4${A&1*4Z-%`BO=2>LWsdv^zV;<0tv$kWdHyG diff --git a/src/project_layouts/vendor/punk/project-0.1/src/make.tcl b/src/project_layouts/vendor/punk/project-0.1/src/make.tcl index 24206ba7..f2aa3155 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/make.tcl +++ b/src/project_layouts/vendor/punk/project-0.1/src/make.tcl @@ -1,20 +1,159 @@ # tcl # -#make any tclkits and modules in src and place them and associated data files/scripts in the parent folder of src. +# punkboot - make any tclkits and modules in /src folders and place them and associated data files/scripts in the parent folder of src. #e.g in 'bin' and 'modules' folders at same level as 'src' folder. - set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" puts $hashline -puts " punkshell make script " +puts " Punk Boot" puts $hashline\n -namespace eval ::punkmake { + +package prefer latest +lassign [split [info tclversion] .] tclmajorv tclminorv + +global A ;#UI Ansi code array +array set A {} + +namespace eval ::punkboot { variable scriptfolder [file normalize [file dirname [info script]]] variable foldername [file tail $scriptfolder] variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] variable non_help_flags [list -k] - variable help_flags [list -help --help /?] - variable known_commands [list project modules info check shell vendorupdate bootsupport vfscommonupdate] + variable help_flags [list -help --help /? -h] + variable known_commands [list project modules vfs info check shell vendorupdate bootsupport vfscommonupdate] } + + + +namespace eval ::punkboot::lib { + proc tm_version_isvalid {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionpart $versionpart]]} { + return 1 + } else { + return 0 + } + } + proc tm_version_major {version} { + if {![tm_version_isvalid $version]} { + error "Invalid version '$version' is not a proper Tcl module version number" + } + set firstpart [lindex [split $version .] 0] + #check for a/b in first segment + if {[string is integer -strict $firstpart]} { + return $firstpart + } + if {[string first a $firstpart] > 0} { + return [lindex [split $firstpart a] 0] + } + if {[string first b $firstpart] > 0} { + return [lindex [split $firstpart b] 0] + } + error "tm_version_major unable to determine major version from version number '$version'" + } + proc tm_version_canonical {ver} { + #accepts a single valid version only - not a bounded or unbounded spec + if {![tm_version_isvalid $ver]} { + error "tm_version_canonical version '$ver' is not valid for a package version" + } + set parts [split $ver .] + set newparts [list] + foreach o $parts { + set trimmed [string trimleft $o 0] + set firstnonzero [string index $trimmed 0] + switch -exact -- $firstnonzero { + "" { + lappend newparts 0 + } + a - b { + #e.g 000bnnnn -> bnnnnn + set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] + if {$tailtrimmed eq ""} { + set tailtrimmed 0 + } + lappend newparts 0$firstnonzero$tailtrimmed + } + default { + #digit + if {[string is integer -strict $trimmed]} { + #e.g 0100 -> 100 + lappend newparts $trimmed + } else { + #e.g 0100b003 -> 100b003 (still need to process tail) + if {[set apos [string first a $trimmed]] > 0} { + set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}a${rhs} + } elseif {[set bpos [string first b $trimmed]] > 0} { + set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}b${rhs} + } else { + #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b + error "tm_version_canonical error - trimfail - unexpected" + } + } + } + } + } + return [join $newparts .] + } + proc tm_version_required_canonical {versionspec} { + #also trim leading zero from any dottedpart? + #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. + #e.g 1.01 is equivalent to 1.1 and 01.001 + #also 1b3 == 1b0003 + + if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version + set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification" + if {[string first - $versionspec] < 0} { + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form + set from $versionspec + if {![::punkboot::lib::tm_version_isvalid $from]} { + error "$errmsg '$versionpec'" + } + if {![catch {::punkboot::lib::tm_version_major $from} majorv]} { + set from [tm_version_canonical $from] + return "${from}-[expr {$majorv +1}]" + } else { + error "$errmsg '$versionspec'" + } + } else { + # min- or min-max + #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) + set parts [split $versionspec -] ;#we expect only 2 parts + lassign $parts from to + if {![::punkboot::lib::tm_version_isvalid $from]} { + error "$errmsg '$versionspec'" + } + set from [tm_version_canonical $from] + if {[llength $parts] == 2} { + if {$to ne ""} { + if {![::punkboot::lib::tm_version_isvalid $to]} { + error "$errmsg '$versionspec'" + } + set to [tm_version_canonical $to] + return $from-$to + } else { + return $from- + } + } else { + error "$errmsg '$versionspec'" + } + error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" + } + } + +} + if {"::try" ni [info commands ::try]} { puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" exit 1 @@ -23,30 +162,100 @@ if {"::try" ni [info commands ::try]} { #------------------------------------------------------------------------------ #Module loading from src/bootsupport or [pwd]/modules if pwd is a 'src' folder #------------------------------------------------------------------------------ -#If the there is a folder under the current directory /src/bootsupport/modules which contains .tm files +#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files # - then it will attempt to preference these modules -# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the make script +# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the boot script # and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables set startdir [pwd] +#we are focussed on pure-tcl libs/modules in bootsupport for now. +#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc +#REVIEW - punkboot can really speed up with appropriate accelerators and/or external binaries +# - we need to support that without binary downloads from repos unless the user explicitly asks for that. +# - They may already be available in the vfs (or pointed to package paths) of the running executable. +# - todo: some user prompting regarding installs with platform-appropriate package managers +# - todo: some user prompting regarding building accelerators from source. + +# ------------------------------------------------------------------------------------- +set bootsupport_module_paths [list] +set bootsupport_library_paths [list] if {[file exists [file join $startdir src bootsupport]]} { - set bootsupport_mod [file join $startdir src bootsupport modules] - set bootsupport_lib [file join $startdir src bootsupport lib] + lappend bootsupport_module_paths [file join $startdir src bootsupport modules] + lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv] + lappend bootsupport_library_paths [file join $startdir src bootsupport lib] + lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv] } else { - set bootsupport_mod [file join $startdir bootsupport modules] - set bootsupport_lib [file join $startdir bootsupport lib] + lappend bootsupport_module_paths [file join $startdir bootsupport modules] + lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv] + lappend bootsupport_library_paths [file join $startdir bootsupport lib] + lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv] +} +set bootsupport_paths_exist 0 +foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] { + if {[file exists $p]} { + set bootsupport_paths_exist 1 ;#at least one exists + break + } } +# ------------------------------------------------------------------------------------- +# ------------------------------------------------------------------------------------- +set sourcesupport_module_paths [list] +set sourcesupport_library_paths [list] +set sourcesupport_paths_exist 0 +#we deliberately don't use [pwd]/modules because commonly the launch dir may be the project dir. +#The /modules are the very modules we are building - and may be in a broken state, which punkboot then can't fix. +#The 'building' is generally just assigning a version instead of 999999.0a1 (and some doc string substitution?) +#(most?) Modules in src/modules etc should still be runnable directly in certain cases like this where we point to them. +if {[file tail $startdir] eq "src"} { + #todo - other src 'module' dirs.. + foreach p [list $startdir/modules $startdir/modules_tcl$::tclmajorv $startdir/vendormodules $startdir/vendormodules_tcl$::tclmajorv] { + if {[file exists $p]} { + lappend sourcesupport_module_paths $p + } + } + # -- -- -- + foreach p [list $startdir/lib $startdir/lib_tcl$::tclmajorv $startdir/vendorlib $startdir/vendorlib_tcl$::tclmajorv] { + if {[file exists $p]} { + lappend sourcesupport_library_paths $p + } + } + # -- -- -- + foreach p [list {*}$sourcesupport_module_paths {*}$sourcesupport_library_paths] { + if {[file exists $p]} { + set sourcesupport_paths_exist 1 + break + } + } + + if {$sourcesupport_paths_exist} { + #launch from auto_path $::auto_path" - #we deliberately don't use [pwd]/modules because commonly the launch dir may be the project dir. - #The /modules are the very modules we are building - and may be in a broken state, which make.tcl then can't fix. - if {[file tail $startdir] eq "src"} { - if {[file exists $startdir/modules]} { - #launch from .' (minbounded) as .- ie explicitly convert to corresponding bounded form +#put some with leading zeros to test normalisation +set ::punkboot::bootsupport_requirements [dict create\ + punk::repo [list version "00.01.01-"]\ + punk::mix [list version ""]\ + punk::ansi [list]\ + overtype [list version "1.6.5-"]\ + punkcheck [list]\ + fauxlink [list version "0.1.1-"]\ + textblock [list version 0.1.1-]\ + fileutil::traverse [list]\ + md5 [list version 2-]\ +] + +#while we are converting plain version numbers to explicit bounded form - we'll also do some validation of the entries +dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { + if {[dict exists $pkginfo version]} { + set ver [string trim [dict get $pkginfo version]] + if {![catch {::punkboot::lib::tm_version_required_canonical $ver} canonical]} { + if {$canonical ne $ver} { + dict set pkginfo version $canonical ;# plain ver mapped to min-max. min- and min-max and empty left as is + dict set ::punkboot::bootsupport_requirements $pkg $pkginfo + } + } else { + puts stderr "punkboot::bootsupport_requirements - package $pkg has invalid version specification '$ver'" + exit 1 + } + } else { + #make sure each has a blank version entry if nothing was there. + dict set pkginfo version "" + dict set ::punkboot::bootsupport_requirements $pkg $pkginfo + } +} +#Assert - our bootsupport_requirement version numbers should now be either empty or of the form min- or min-max +#dict for {k v} $::punkboot::bootsupport_requirements { +# puts "- $k $v" +#} + +#some of our toplevel package specified in bootsupport_requirements may trigger 'package require' for dependencies that we know are optional/not required. +#By listing them here we can produce better warnings +set ::punkboot::bootsupport_optional [dict create\ + tcllibc [list -note {improves performance significantley}]\ + twapi [list]\ + patternpunk [list]\ + cryptkit [list -note {accelerates some packages}]\ + Trf [list -note {accelerates some packages}]\ +] +set ::punkboot::bootsupport_recommended [dict create\ + tcllibc [list -note {improves performance significantley}]\ +] + # ** *** *** *** *** *** *** *** *** *** *** *** -#*temporarily* hijack package command +# create an interp in which we hijack package command +# This allows us to auto-gather some dependencies (not necessarily all and not necessarily strictly required) +# Note: even in a separate interp we could still possibly get side-effects if a package has compiled components - REVIEW +# Hopefully the only side-effect is that a subsequent load of the package will be faster... +# (punk boot is intended to operate without compiled components - but some could be pulled in by tcl modules if they're found) +# (tcllibc is also highly desirable as the performance impact when not available can be dramatic.) +# ... but if the binary is loaded with a different path name when we come to actually use it - there could be issues. +# A truly safe way to do this might be to call out to a separate process, or to relaunch after checks. (todo?) +# A truly accurate way to do this is to have dependencies properly recorded for every package - +# something the package developer would have to provide - or an analyst would have to determine by looking at the code. +# (to check for 'package require' statements that are actually optional, one-or-more-of-n, mutually-exclusive, anti-requirements etc) +# Such information may also vary depending on what features of the package are to be used here - so it's a tricky problem. +# +# Nevertheless - the auto-determination can be a useful warning to the punk boot developer that something may be missing in the bootsupport. +# +# A further auto-determination for optionality could potentially be done in yet another interp by causing package require to fake-error on a dependency - +# and see if the parent still loads. This would still be more time and complexity for a still uncertain result. +# e.g a package may be a strong requirement for the package being examined iff another optional package is present (which doesn't itself require that dependency) +# - it's unclear that reasonable determinations always can be made. +# There are also packages that aren't required during one package's load - but are required during certain operations. # ** *** *** *** *** *** *** *** *** *** *** *** -try { - rename ::package ::punkmake::package_temp_aside - proc ::package {args} { - if {[lindex $args 0] eq "require"} { - lappend ::punkmake::pkg_requirements [lindex $args 1] +proc ::punkboot::check_package_availability {args} { + #best effort at auto-determinining packages required (dependencies) based on top-level packages in the list. + #Without fully parsing the package-loading Tcl scripts and examining all side-effects (an unlikely capability), + # this is not going to be as accurate as the package developer providing a definitive list of which packages are required and which are optional. + # 'optionality' is a contextual concept anyway depending on how the package is intended to be used. + # The package developer may consider a feature optional - but it may not be optional in a particular usecase. + + set bootsupport_requirements [lindex $args end] + set usage "punkboot::check_package_availability ?-quiet 0|1? package_list" + if {![llength $bootsupport_requirements]} { + error "usage: $usage" + } + set opts [lrange $args 0 end-1] + if {[llength $opts] % 2 != 0} { + error "incorrect number of arguments. usage: $usage" + } + set defaults [dict create\ + -quiet 1\ + ] + set opts [dict merge $defaults $opts] + set opt_quiet [dict get $opts -quiet] + + interp create testpkgs + interp eval testpkgs [list package prefer [package prefer]] + interp eval testpkgs { + namespace eval ::test {} + set ::test::pkg_requested [list] ;#list of pairs (pkgname version_requested) version_requested is 'normalised' (min- /min-max only) or empty + set ::test::pkg_loaded [list] + set ::test::pkg_missing [list] + set ::test::pkg_broken [list] + set ::test::pkg_info [dict create] + tcl::tm::remove {*}[tcl::tm::list] + set ::auto_path [list] + } + #sync interp package paths with current state of package/library paths + interp eval testpkgs [list ::tcl::tm::add {*}[tcl::tm::list]] + interp eval testpkgs [list set ::auto_path $::auto_path] + interp eval testpkgs [list set ::test::bootsupport_requirements $bootsupport_requirements] + interp eval testpkgs [list set ::argv0 $::argv0] + interp eval testpkgs [list set ::opt_quiet $opt_quiet] + + + interp eval testpkgs { + #try { + rename ::package ::package_orig + variable ns_scanned [list] + # + proc ::tm_version_major {version} { + #if {![tm_version_isvalid $version]} { + # error "Invalid version '$version' is not a proper Tcl module version number" + #} + set firstpart [lindex [split $version .] 0] + #check for a/b in first segment + if {[string is integer -strict $firstpart]} { + return $firstpart + } + if {[string first a $firstpart] > 0} { + return [lindex [split $firstpart a] 0] + } + if {[string first b $firstpart] > 0} { + return [lindex [split $firstpart b] 0] + } + error "tm_version_major unable to determine major version from version number '$version'" + } + proc ::package {args} { + variable ns_scanned + if {[lindex $args 0] eq "require"} { + #review - difference between errors due to bad requirements format vs package missing/failed + #we should probably still put syntax errors into the datastructure to be ultimately shown to the user + if {[lindex $args 1] eq "-exact"} { + set pkgname [lindex $args 2] + set raw_requirements_list [lrange $args 3 end] + #review - what to do with invalid extra args? Normally it would raise an error + set version_requested [lindex $raw_requirements_list 0] ;#for now treat as exactly one requirement when -exact + #normalise! + set version_requested "$version_requested-$version_requested" + lappend requirements_list $version_requested + } else { + set pkgname [lindex $args 1] + #usually only a single requirement - but we must handle multiple + set raw_requirements_list [lrange $args 2 end] ;#may be also be pattern like ver- (min-unbounded) or ver1-ver2 (bounded) (which will match >=ver1 but strictly < ver2) (or like -exact if ver1=ver2) + set requirements_list [list] + foreach requirement $raw_requirements_list { + #set requirement [::punkboot::lib::tm_version_required_canonical $requirement] + #todo - work out how to get normalisation code in interp + if {[string trim $requirement] ne ""} { + if {[string first - $requirement] < 0} { + #plain ver - normalise to ver-nextmajor + #todo - we should fully normalise as we do in main script! (e.g leading zeroes - even though these should be rare) + set m [::tm_version_major $requirement] + set nextm [expr {$m +1}] + lappend requirements_list $requirement-$nextm + } else { + #has dash - we should normalize so keys match even if leading zeros! + lappend requirements_list $requirement + } + } else { + #empty or whitespace spec not allowed - should be syntax error + #add it to list anyway so that the underlying package call later can fail it appropriately + lappend requirements_list $requirement + } + } + #assert - added an entry for every raw requirement - even if doesn't appear to be valid + + #$requirements_list may be empty = any version satisfies. + } + + #should still distinguish: {pkgname {}} -valid vs {pkgname {{}}} due to empty string supplied in call - invalid - but leave for underlying package command to error on + set pkgrequest [list $pkgname $requirements_list] + if {$pkgrequest ni $::test::pkg_requested} { + lappend ::test::pkg_requested $pkgrequest + } + + # -- -- --- --- --- --- --- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Must ensure a scan has been done in the relevant subpath before attempting to gether package vervsion + set nsquals [namespace qualifiers $pkgname] + if {$nsquals ne "" && $nsquals ni $ns_scanned} { + catch {::package_orig require ${nsquals}::zzz-nonexistant} ;#scan every ns encountered once - or we will get no result from 'package versions' for sub namespaces. + lappend ns_scanned $nsquals + } + set versions [::package_orig versions $pkgname] + #An empty result from versions doesn't always indicate we can't load the package! + #REVIEW - known to happen with 'package versions Tcl' - what other circumstances? + # -- -- --- --- --- --- --- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + #fill in a blank pinfo dict to get some consistent ordering + if {[dict exists $::test::pkg_info $pkgrequest]} { + set pinfo [dict get $::test::pkg_info $pkgrequest] + } else { + set pinfo [dict create version "" versions $versions version_requested $requirements_list required_by [list]] + } + if {[llength $::test::pkg_stack]} { + set caller [lindex $::test::pkg_stack end] + set required_by [dict get $pinfo required_by] + if {$caller ni $required_by} { + lappend required_by $caller + } + dict set pinfo required_by $required_by + } + lappend ::test::pkg_stack $pkgname + + #At this point we could short circuit if we've already classified this package/requirements combo as missing/broken from a previous require + #review - there is some chance the exact pkg/requirements combo may succeed after an earlier failure if some package adjusted search paths.. + #however - the pkg should maintain a failure record - treating it as successful is likely to hide relevant info + if {$pkgrequest in [list {*}$::test::pkg_missing {*}$::test::pkg_broken]} { + set ::test::pkg_stack [lrange $::test::pkg_stack 0 end-1] + dict set ::test::pkg_info $pkgrequest $pinfo + return + } + + #use our normalised requirements instead of original args + #if {[catch [list ::package_orig {*}$args] result]} {} + if {[catch [list ::package_orig require $pkgname {*}$requirements_list] result]} { + dict set pinfo testerror $result + #package missing - or exists - but failing to initialise + if {!$::opt_quiet} { + set parent_path [lrange $::test::pkg_stack 0 end-1] + puts stderr "\x1b\[32m $pkgname versions: $versions error: $result\x1b\[m" + set parent_path [join $parent_path " -> "] + puts stderr "pkg requirements: $parent_path" + puts stderr "error during : '$args'" + puts stderr " \x1b\[93m$result\x1b\[m" + } + + #the failed package may still exist - so we could check 'package files' and 'package ifneeded' here too - REVIEW + #to determine the version that we attempted to load, + #- we need to look at 'pkg versions' vs -exact / ver / ver-ver (using package vsatisfies) + if {![llength $versions]} { + #no versions *and* we had an error - missing is our best guess. review. + #'package versions Tcl' never shows any results + #so requests for old versions will show as missing not broken. + #This is probably better anyway. + if {$pkgrequest ni $::test::pkg_missing} { + lappend ::test::pkg_missing $pkgrequest + } + } else { + if {$pkgrequest ni $::test_pkg_broken} { + lappend ::test::pkg_broken $pkgrequest + } + + #all we know about failed pkg is in the error $result + #we can't reliably determine which version of possibly many it was trying to load just based on error msgs. + #(we often could - but not always) + #Instead - use the properly ordered versions and knowledge of which pkg 'package require' would have picked. + + #'package versions' does not always return ordered earliest to latest! (e.g 'package versions http' -> 2.10b1 2.9.8) + set ordered_versions [lsort -command {::package_orig vcompare} [::package_orig versions $pkgname]] + if {[::package_orig prefer] eq "stable"} { + #to support 'package prefer' = stable we have to strip alpha/beta versions + set selectable_versions [list] + foreach v $ordered_versions { + if {[string match *a* $v] || [string match *b* $v]} { + #presence of an a or b indicates 'unstable' + continue + } + lappend selectable_versions $v + } + } else { + #we are operating under 'package prefer' = latest + set selectable_versions $ordered_versions + } + + if {[llength $requirements_list]} { + #add one or no entry for each requirement. + #pick highest at end + set satisfiers [list] + foreach requirement $requirements_list { + foreach ver [lreverse $selectable_versions] { + if {[package vsatisfies $ver $requirement]} { + lappend satisfiers $ver + break + } + } + } + if {[llength $satisfiers]} { + set satisfiers [lsort -command {::package_orig vcompare} $satisfiers] + dict set pinfo version [lindex $satisfiers end] + } + } else { + #package require will have picked highest/latest + dict set pinfo version [lindex $selectable_versions end] + } + } + + + #Note that we must return without error in order to gather 'probable' dependencies. + #This is not completely accurate - as a lib/module may have wrapped a 'package require' in a catch + #In such a case the 'dependency' might be optional - but we currently have no way of determining this. + #By not returning an error - the loaded package may not behave correctly (e.g package state variables set differently?) + #- hence this is all done in a separate interp to be discarded. + #Note that pkgIndex.tcl scripts may commonly just 'return' and fail to do a 'package provide' + # - presumably the standard package require still raises an error in that case though - so it is different? + # - e.g at least some versions of struct::list did this. resulting in "can't find package struct::list" for tcl versions not supported. + # - even thoug it did find a package for struct::list. + set ::test::pkg_stack [lrange $::test::pkg_stack 0 end-1] + dict set ::test::pkg_info $pkgrequest $pinfo + return + } else { + #package loaded ok + lappend ::test::pkg_loaded $pkgrequest + set ifneeded_script [list uplevel 1 [list ::package_orig ifneeded $pkgname]] ;#not guaranteed to be a tcl list? + set pinfo [dict merge $pinfo [dict create version $result raw_ifneeded $ifneeded_script]] + + set ::test::pkg_stack [lrange $::test::pkg_stack 0 end-1] + set relevant_files [list] + if {![catch {::package_orig files Tcl} ]} { + #tcl9 (also some 8.6/8.7) has 'package files' subcommand. + #unfortunately, in some cases (e.g md5 when no accelerators available) this can be a huge list (1000+) showing all scanned pkgIndex.tcl files from unrelated packages. + #We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour + #see: https://core.tcl-lang.org/tcl/tktview/209fd9adce + set all_files [::package_orig files $pkgname] + #some arbitrary threshold? REVIEW + if {[llength $all_files] > 10} { + dict set pinfo warning "files_sourced_during_load=[llength $all_files]" + } else { + set relevant_files $all_files + dict set pinfo packagefiles $relevant_files + } + } + if {![llength $relevant_files]} { + dict set pinfo packagefiles {} ;#default + #there are all sorts of scripts, so this is not predictably structured + #e.g using things like apply + #we will attempt to get a trailing source .. + set parts [split [string trim $ifneeded_script] {;}] + set trimparts [list] + foreach p $parts { + lappend trimparts [string trimright $p] + } + set last_with_text [lsearch -inline -not [lreverse $trimparts] ""] ;#could return empty if all blank + #we still don't assume any line is a valid tcl list.. + if {$last_with_text ne "" && [regexp -- {\S+$} $last_with_text lastword]} { + #if it's a file or dir - close enough (?) + #e.g tcllibc uses apply and the last entry is actuall a folder used to find the file.. + #we aren't brave enough to try to work out the actual file(s) + if {[file exists $lastword]} { + dict set pinfo packagefiles $lastword + } + } + } + dict set ::test::pkg_info $pkgrequest $pinfo + return $result + } + } else { + #puts stderr "package $args" + return [uplevel 1 [list ::package_orig {*}$args]] + } + } + + set ::test::pkg_stack [list] + catch {::package_orig require zzz-non-existant} ;#scan so we get 'package versions' results + dict for {pkg pkgdict} $::test::bootsupport_requirements { + #set nsquals [namespace qualifiers $pkg] + #if {$nsquals ne ""} { + # catch {::package_orig require ${nsquals}::zzz-non-existant} ;#force scan of every level encountered + #} + set ::test::pkg_stack [list] + #run the instrumented 'package require' on the toplevel requirements + # dict key version always exists in pkgdict - version is empty or normalised to min- or min-max + set wanted [dict get $pkgdict version] + catch {package require $pkg {*}$wanted} + } + #} finally { + # #not strictly necessary as we'll tear down the interp + # catch {rename ::package ""} + # catch {rename ::package_orig ::package} + #} + # ** *** *** *** *** *** *** *** *** *** *** *** + + #note we will have entries for each different way package was requested + set ::test::pkg_requested [lsort -unique $::test::pkg_requested] + + #foreach pkg $::test::pkg_requested { + # set ver [package provide $pkg] + # if {$ver eq ""} { + # #puts stderr "missing pkg: $pkg" + # lappend ::test::pkg_missing $pkg + # } else { + # if {[string tolower $pkg] eq "tcl"} { + # #ignore + # #continue + # } + # lappend ::test::pkg_loaded $pkg + # } + #} + } + #extract results from testpkgs interp + set requested [interp eval testpkgs {set ::test::pkg_requested}] + set loaded [interp eval testpkgs {set ::test::pkg_loaded}] + set missing [interp eval testpkgs {set ::test::pkg_missing}] + set broken [interp eval testpkgs {set ::test::pkg_broken}] + set pkginfo [interp eval testpkgs {set ::test::pkg_info}] + interp delete testpkgs + + #now run the normal package require on every pkg to see if our 'broken' assignments are correct? + #by returning without error in our fake package require - we have potentially miscategorised some in both the 'broken' and 'loaded' categories. + #a) - packages that are broken due to missing dependency but we haven't reported as such (the common case) + #b) - packages that we reported as broken because they tried to use a function from an optional dependency we didn't error on + #c) - other cases + # + #Note also by not erroring on a package require the package may have not attempted to load another package that would do the job. + #This is a case where we may completely fail to report a one-of-n dependency for example + # - hard to test without repeated runs :/ + #todo - another interp? + #a 'normal' run now may at least mark/unmark some 'broken' packages and give at least some better feedback. + #we will test all discovered packages from the above process except those already marked as 'missing' + #both 'broken' and 'loaded' are still suspect at this point. + #we will attempt to load the -exact version that the previous test either appeared to load or fail in loading. + #Presumably that is the one that would be loaded in the normal course anyway - REVIEW. + #(as well as 'requestd' not guaranteed to be complete - but we will live with that for the purposes here) + interp create normaltest + interp eval normaltest [list package prefer [package prefer]] + interp eval normaltest { + set ::pkg_broken [list] + set ::pkg_loaded [list] + set ::pkg_errors [dict create] + tcl::tm::remove {*}[tcl::tm::list] + set ::auto_path [list] + } + + set test_packages [list] + foreach pkgrequest $requested { + lassign $pkgrequest pkgname requirements_list + if {$pkgrequest ni $missing} { + if {[dict exists $pkginfo $pkgrequest version]} { + set tried_version [dict get $pkginfo $pkgrequest version] + } else { + set tried_version "" + } + lappend test_packages [list $pkgname $tried_version $requirements_list] } } - package require punk::mix - package require punk::repo - package require punk::ansi - package require overtype -} finally { - catch {rename ::package ""} - catch {rename ::punkmake::package_temp_aside ::package} + + #sync interp package paths with current state of package/library paths + interp eval normaltest [list ::tcl::tm::add {*}[tcl::tm::list]] + interp eval normaltest [list set ::auto_path $::auto_path] + interp eval normaltest [list set ::test_packages $test_packages] + interp eval normaltest [list set ::argv0 $::argv0] + interp eval normaltest [list set ::opt_quiet $opt_quiet] + + interp eval normaltest { + foreach testinfo $::test_packages { + lassign $testinfo pkgname ver requirements_list + + #if {$ver eq ""} { + # set require_script [list package require $pkgname] + #} else { + # set require_script [list package require $pkgname $ver-$ver] ;#bounded same version - equivalent to -exact + #} + set require_script [list package require $pkgname {*}$requirements_list] + + #puts "finaltest $pkgname requested:$requirements_list" + if {[catch $require_script result]} { + lappend ::pkg_broken [list $pkgname $requirements_list] + dict set ::pkg_errors [list $pkgname $requirements_list] $result + } else { + #result is version we actually got - without the previous interp's fudgery + if {![llength $requirements_list] || [package vsatisfies $result {*}$requirements_list]} { + lappend ::pkg_loaded [list $pkgname $requirements_list] + } else { + lappend ::pkg_broken [list $pkgname $requirements_list] + dict set ::pkg_errors [list $pkgname $requirements_list] "Version conflict for package \"$pkgname\": have $result, need $requirements_list" + #standard err msg but capital V to differentiate + #Differs from standard in that we have normalised exacts to ver-ver - so will report in that form instead of e.g 0-1 -exact 1.0 1b3-2 + } + } + } + } + set actually_failed [interp eval normaltest [list set ::pkg_broken]] + set pkg_errors [interp eval normaltest [list set ::pkg_errors]] ;#dict + set actually_loaded [list] + set actually_loaded_names [list] + set actually_broken [list] + foreach pkgrequest $requested { + if {$pkgrequest in $missing} { + continue + } + if {$pkgrequest in $actually_failed} { + lappend actually_broken $pkgrequest + } else { + lappend actually_loaded $pkgrequest + if {[lindex $pkgrequest 0] ni $actually_loaded_names} { + lappend actually_loaded_names [lindex $pkgrequest 0] + } + } + } + + dict for {pkg_req err} $pkg_errors { + dict set pkginfo $pkg_req error $err + } + + interp delete normaltest + set pkgstate [dict create requested $requested loaded $actually_loaded loadednames $actually_loaded_names missing $missing broken $actually_broken info $pkginfo] + + #debug + #dict for {k v} $pkgstate { + # puts stderr " - $k $v" + #} + return $pkgstate } -# ** *** *** *** *** *** *** *** *** *** *** *** -foreach pkg $::punkmake::pkg_requirements { - if {[catch {package require $pkg} errM]} { - puts stderr "missing pkg: $pkg" - lappend ::punkmake::pkg_missing $pkg - } else { - lappend ::punkmake::pkg_loaded $pkg + + +#called when only-bootsupport or bootsupport+external module/lib paths active. +#flags for ui-feature relevant packages +proc ::punkboot::package_bools {pkg_availability} { + set pkgbools [dict create] + set requirements [dict create\ + overtype 1.6.5-\ + textblock 0.1.1-\ + punk::ansi 0.1.1-\ + ] + #'dict get $pkg_availability loaded] is a list of {pkgname requrement} pairs + #set loaded_names [lmap i [lsearch -all -index 0 -subindices [dict get $pkg_availability loaded] *] {lindex $loaded $i}] ;#return list of first elements in each tuple + set loaded_names [dict get $pkg_availability loadednames] ;#prebuilt list of names + dict for {pkgname req} $requirements { + #each req could in theory be a list + if {$pkgname in $loaded_names} { + #get first loaded match - use version from it (all info records for {pkgname *} should have same version that was actually loaded) + set first_loaded [lsearch -inline -index 0 [dict get $pkg_availability loaded] $pkgname] + set loaded_version [dict get $pkg_availability info $first_loaded version] + if {![llength $req] || [package vsatisfies $loaded_version {*}$req]} { + dict set pkgbools $pkgname 1 + } else { + dict set pkgbools $pkgname 0 + } + } else { + dict set pkgbools $pkgname 0 + } } + return $pkgbools } +proc ::punkboot::get_display_missing_packages {pkg_availability} { + array set haspkg [punkboot::package_bools $pkg_availability] ;#convenience e.g if {$haspkg(textblock)} ... + global A + if {![array size A]} { + punkboot::define_global_ansi $pkg_availability + } + set missing_rows [list] + set fields_blank_missing [dict create\ + status ""\ + package ""\ + version_requested ""\ + versions ""\ + optional ""\ + recommended ""\ + required_by ""\ + ] + foreach pkg_req [dict get $pkg_availability missing] { + lassign $pkg_req pkgname requirements_list + set fields $fields_blank_missing + dict set fields status "missing" + dict set fields package $pkg_req + if {[dict exists $::punkboot::bootsupport_optional $pkgname]} { + dict set fields optional " ${A(OK)}(known optional)$A(RST)" + } + if {[dict exists $::punkboot::bootsupport_recommended $pkgname]} { + dict set fields recommended "${A(HIGHLIGHT)}(RECOMMENDED)$A(RST)" + } + if {[dict exists $pkg_availability info $pkg_req required_by]} { + dict set fields required_by [dict get $pkg_availability info $pkg_req required_by] + } + lappend missing_rows $fields + } + set missing_out "" + set c1_width 40 + foreach row $missing_rows { + if {$haspkg(overtype)} { + set line " [overtype::left [string repeat " " $c1_width] $A(BWHITE)[dict get $row package]$A(RST)]" + } else { + set line " [format "%-*s" $c1_width [dict get $row package]]" + } + append line " [dict get $row status]" + append line " [dict get $row optional]" + append line " [dict get $row recommended]" + append line " requested_by:[join [dict get $row required_by] {, }]" + append missing_out $line \n + } + return $missing_out +} +proc ::punkboot::get_display_broken_packages {pkg_availability} { + array set haspkg [punkboot::package_bools $pkg_availability] ;#convenience e.g if {$haspkg(textblock)} ... + global A + if {![array size A]} { + punkboot::define_global_ansi $pkg_availability + } + set broken_rows [list] + set fields_blank_broken [dict create\ + status ""\ + package ""\ + version ""\ + optional ""\ + recommended ""\ + required_by ""\ + error ""\ + ] + foreach pkg_req [dict get $pkg_availability broken] { + lassign $pkg_req pkgname vrequested + set fields $fields_blank_broken + dict set fields status "broken" + dict set fields package $pkg_req + + if {[dict exists $pkg_availability info $pkg_req version]} { + dict set fields version [dict get $pkg_availability info $pkg_req version] + } + if {[dict exist $::punkboot::bootsupport_optional $pkgname]} { + dict set fields optional "${A(OK)}(known optional)$A(RST)" + } + if {[dict exists $::punkboot::bootsupport_recommended $pkgname]} { + dict set fields recommended "${A(HIGHLIGHT)}(RECOMMENDED)$A(RST)" + } + set requiredby_list [list] + if {[dict exists $::punkboot::bootsupport_requirements $pkgname]} { + #punkboot also asked for this pkgname + #the question of what other packages would also be satisfied had this request not been broken isn't necessarily something we need to answer here + #we do so for punkboot anyway - but it's inclusion as 'requiredby or requestedby' isn't strictly accurate - + # it is more like: would also be satisfied by + #what is 'broken' may depend on what order packages were loaded + #e.g if a package already required a specific low version (that was optional for it) that another then fails on because a different version was not optional for that later package. + #puts stderr "$pkgname===$::punkboot::bootsupport_requirements" + set pboot_required [dict get $::punkboot::bootsupport_requirements $pkgname version] ;#version key always present and empty or normalised + if {[list $pkgname $pboot_required] eq $pkg_req} { + #pboot had same requirespec as this broken record + set requiredby_list [list punkboot] + } elseif {[dict exists $pkg_availability info $pkg_req version]} { + set vtried [dict get $pkg_availability info $pkg_req version] + if {[dict exists $pkg_availability broken [list $pkgname $pboot_required]]} { + #punkboot didn't get what it wanted directly + if {$pboot_required eq "" || [package vsatisfies $vtried $pboot_required]} { + #REVIEW + #e.g punkboot might require no specific version - and this fail record might be for a specific version + #we only list punkboot against this request if it's request also failed - but would be satisfied by this failure if it had worked + set requiredby_list [list punkboot] + } + } + } + } + if {[dict exists $pkg_availability info $pkg_req required_by]} { + lappend requiredby_list {*}[dict get $pkg_availability info $pkg_req required_by] + } + dict set fields required_by $requiredby_list + + if {[dict exists $pkg_availability info $pkg_req error]} { + dict set fields error "[dict get $pkg_availability info $pkg_req error]" + } + + lappend broken_rows $fields + } + set broken_out "" + set c1_width 40 + set c3_width 20 + set c3 [string repeat " " $c3_width] + foreach row $broken_rows { + if {$haspkg(overtype)} { + set line " [overtype::left [string repeat " " $c1_width] $A(BAD)[dict get $row package]$A(RST)]" + } else { + set line " [format "%-*s" $c1_width [dict get $row package]]" + } + append line " [dict get $row status]" + if {[dict get $row version] ne ""} { + set txt " ver:[dict get $row version]" + append line [format "%-*s" $c3_width $txt] + } else { + append line $c3 + } + if {[dict get $row optional] ne ""} { + append line [dict get $row optional] + } + if {[dict get $row recommended] ne ""} { + append line [dict get $row recommended] + } + if {[dict get $row required_by] ne ""} { + append line " requested_by:[join [dict get $row required_by] {, }]" + } + if {[dict get $row error] ne ""} { + append line " err:[dict get $row error]" + } + append broken_out $line \n + } + return $broken_out +} +proc ::punkboot::define_global_ansi {pkg_availability} { + #stick to basic colours for themable aspects ? + # + array set haspkg [punkboot::package_bools $pkg_availability] ;#convenience e.g if {$haspkg(textblock)} ... + global A + set A(RST) \x1b\[m + if {!$haspkg(punk::ansi)} { + set A(HIGHLIGHT) \x1b\[93m ;#brightyellow + set A(BWHITE) \x1b\[97m ;#brightwhite + set A(OK) \x1b\[92m ;#brightgreen + set A(BAD) \x1b\[33m ;# orange + set A(ERR) \x1b\[31m ;# red + } else { + namespace eval ::punkboot { + namespace import ::punk::ansi::a+ ::punk::ansi::a + } + set A(HIGHLIGHT) [a+ brightyellow] + set A(BWHITE) [a+ brightwhite] + set A(OK) [a+ web-lawngreen] ;#brightgreen + set A(BAD) [a+ web-orange] + set A(ERR) [a+ web-indianred] ;#easier on the eyes than standard red on some screens + } +} +proc ::punkboot::punkboot_gethelp {args} { + #we have currently restricted our package paths to those from 'bootsupport' + #gather details on what is missing so that the info is always reported in help output. + variable pkg_availability + global A + punkboot::define_global_ansi $pkg_availability + array set haspkg [punkboot::package_bools $pkg_availability] ;#convenience e.g if {$haspkg(textblock)} ... -proc punkmake_gethelp {args} { set scriptname [file tail [info script]] append h "Usage:" \n append h "" \n @@ -138,40 +1036,72 @@ proc punkmake_gethelp {args} { append h " - This help." \n \n append h " $scriptname project ?-k?" \n append h " - this is the literal word project - and confirms you want to run the project build - which includes src/vfs/* checks and builds" \n - append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n + append h " - the optional -k flag will terminate running processes matching the executable being built (if applicable)" \n append h " - built modules go into /modules /lib etc." \n \n append h " $scriptname modules" \n - append h " - build modules from src/modules etc without scanning src/runtime and src/vfs folders to build kit/zipkit executables" \n \n + append h " - build modules from src/modules src/vendormodules etc to their corresponding locations under " \n + append h " This does not scan src/runtime and src/vfs folders to build kit/zipkit/cookfs executables" \n \n append h " $scriptname bootsupport" \n append h " - update the src/bootsupport modules as well as the mixtemplates/layouts//src/bootsupport modules if the folder exists" \n + append h " - bootsupport modules are pulled from locations specified in include_modules.config files within each src/bootsupport subdirectory" \n + append h " - This should usually be from modules that have been built and tested in /modules /lib etc." \n append h " - bootsupport modules are available to make.tcl" \n \n append h " $scriptname vendorupdate" \n append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n append h " $scriptname vfscommonupdate" \n - append h " - update the src/vfs/_vfscommon from compiled src/modules and src/lib etc" \n + append h " - update the src/vfs/_vfscommon.vfs from compiled src/modules and src/lib etc" \n append h " - before calling this (followed by make project) - you can test using '(.exe) dev'" \n append h " this will load modules from your /module /lib paths instead of from the kit/zipkit" \n \n append h " $scriptname info" \n - append h " - show the name and base folder of the project to be built" \n + append h " - show the name and base folder of the project to be built" \n \n + append h " $scriptname check" \n + append h " - show module/library paths and any potentially problematic packages for running this script" \n append h "" \n - if {[llength $::punkmake::pkg_missing]} { - append h "* ** NOTE ** ***" \n - append h " punkmake has detected that the following packages could not be loaded:" \n - append h " " [join $::punkmake::pkg_missing "\n "] \n - append h "* ** *** *** ***" \n - append h " These packages are required for punk make to function" \n \n - append h "* ** *** *** ***" \n\n - append h "Successfully Loaded packages:" \n - append h " " [join $::punkmake::pkg_loaded "\n "] \n + if {[llength [dict get $pkg_availability missing]] || [llength [dict get $pkg_availability broken]]} { + set has_recommended 0 + set has_nonoptional 0 + foreach pkg_req [list {*}[dict get $pkg_availability missing] {*}[dict get $pkg_availability broken]] { + lassign $pkg_req pkgname _requirements + if {[dict exists $::punkboot::bootsupport_recommended $pkgname]} { + set has_recommended 1 + break + } + if {![dict exists $::punkboot::bootsupport_optional $pkgname]} { + set has_nonoptional 1 + break + } + } + if {$has_recommended || $has_nonoptional} { + append h "* $A(HIGHLIGHT)** NOTE ** ***$A(RST)" \n + append h " punk boot has detected that the following packages could not be loaded from the bootsystem path:" \n + set missing_out [get_display_missing_packages $pkg_availability] + append h $missing_out + + set broken_out [get_display_broken_packages $pkg_availability] + + append h $broken_out + append h "* $A(HIGHLIGHT)** *** *** ***$A(RST)" \n + append h " These packages are *probably* required for punk boot to function correctly and efficiently" \n + append h " punk boot may still work if they are available elsewhere for the running interpreter" \n + append h " Review to see if bootsupport should be updated" \n + append h " Call 'make.tcl check' and examine the last table (which includes bootsupport + executable-provided packages)" \n + append h " See if there are any items marked missing or broken that aren't marked as '(known optional)'" \n + append h " If all are marked (known optional) then it should work." \n + append h " A package marked (known optional) and (RECOMMENDED) may make the build/install processes run a lot faster. (e.g tcllibc)" \n + append h "* $A(HIGHLIGHT)** *** *** ***$A(RST)" \n\n + #append h "Successfully Loaded packages:" \n + #append h " " [join $::punkboot::pkg_loaded "\n "] \n + } } return $h } + set scriptargs $::argv set do_help 0 if {![llength $scriptargs]} { set do_help 1 } else { - foreach h $::punkmake::help_flags { + foreach h $::punkboot::help_flags { if {[lsearch $scriptargs $h] >= 0} { set do_help 1 break @@ -183,23 +1113,33 @@ foreach a $scriptargs { if {![string match -* $a]} { lappend commands_found $a } else { - if {$a ni $::punkmake::non_help_flags} { + if {$a ni $::punkboot::non_help_flags} { set do_help 1 } } } if {[llength $commands_found] != 1 } { set do_help 1 -} elseif {[lindex $commands_found 0] ni $::punkmake::known_commands} { +} elseif {[lindex $commands_found 0] ni $::punkboot::known_commands} { puts stderr "Unknown command: [lindex $commands_found 0]\n\n" set do_help 1 } if {$do_help} { - puts stderr [punkmake_gethelp] + puts stdout "Checking package availability..." + set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] + foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { + #puts stderr "---> $pkg_request" + lassign $pkg_request pkgname vrequest + set vloaded [dict get $::punkboot::pkg_availability info $pkg_request version] ;#version that was selected to load in response to vrequest during test + #catch {package require $pkgname {*}$vrequest} ;#todo + package require $pkgname {*}$vrequest ;#todo + #package require $pkgname $vloaded-$vloaded + } + puts stdout [::punkboot::punkboot_gethelp] exit 0 } -set ::punkmake::command [lindex $commands_found 0] +set ::punkboot::command [lindex $commands_found 0] if {[lsearch $::argv -k] >= 0} { @@ -210,7 +1150,7 @@ if {[lsearch $::argv -k] >= 0} { #puts stdout "::argv $::argv" # ---------------------------------------- -set scriptfolder $::punkmake::scriptfolder +set scriptfolder $::punkboot::scriptfolder @@ -218,56 +1158,122 @@ set scriptfolder $::punkmake::scriptfolder #If that fails - just look for a 'project shaped folder' ie meets minimum requirements of /src /src/lib /src/modules /lib /modules if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]} { if {![string length [set projectroot [punk::repo::find_candidate $scriptfolder]]]} { - puts stderr "punkmake script unable to determine an approprite project root at or above the path '$scriptfolder' ensure the make script is within a project folder structure" + puts stderr "punkboot script unable to determine an approprite project root at or above the path '$scriptfolder' ensure the make script is within a project folder structure" puts stderr " -aborted- " exit 2 #todo? #ask user for a project name and create basic structure? #call punk::mix::cli::new $projectname on parent folder? } else { - puts stderr "WARNING punkmake script operating in project space that is not under version control" + puts stderr "WARNING punkboot script operating in project space that is not under version control" } } else { } set sourcefolder $projectroot/src -if {$::punkmake::command eq "check"} { +if {$::punkboot::command eq "check"} { + set sep [string repeat - 75] + puts stdout $sep + puts stdout "module/library checks - paths from bootsupport only" + puts stdout $sep puts stdout "- tcl::tm::list" foreach fld [tcl::tm::list] { if {[file exists $fld]} { - puts stdout " $fld" + puts stdout " $fld" } else { - puts stdout " $fld (not present)" + puts stdout " $fld (not present)" } } puts stdout "- auto_path" foreach fld $::auto_path { if {[file exists $fld]} { - puts stdout " $fld" + puts stdout " $fld" } else { - puts stdout " $fld (not present)" + puts stdout " $fld (not present)" } } + flush stdout + set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] + foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { + lassign $pkg_request pkgname vrequest + package require $pkgname {*}$vrequest ;#todo? + } + flush stderr + #punk::lib::showdict -channel stderr $::punkboot::pkg_availability + set missing_out [::punkboot::get_display_missing_packages $::punkboot::pkg_availability] + puts stdout $missing_out\n + + set broken_out [::punkboot::get_display_broken_packages $::punkboot::pkg_availability] + puts stdout $broken_out + set v [package require punk::mix::base] - puts stdout "punk::mix::base version $v\n[package ifneeded punk::mix::base $v]" - exit 0 -} + #don't exit yet - 2nd part of "check" below package path restore +} +# -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- +# - package path restore original module paths and auto_path entries to take effect in addition to bootsupport paths +# - This must be done between the two "check" command sections if {$package_paths_modified} { - #restore module paths and auto_path in addition to the bootsupport ones set tm_list_now [tcl::tm::list] foreach p $original_tm_list { if {$p ni $tm_list_now} { tcl::tm::add $p } } - set ::auto_path [list $bootsupport_lib {*}$original_auto_path] + #set ::auto_path [list $bootsupport_lib {*}$original_auto_path] + lappend ::auto_path {*}$original_auto_path +} +# -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- +#2nd part of "check" +if {$::punkboot::command eq "check"} { + set sep [string repeat - 75] + puts stdout $sep + puts stdout "module/library checks - paths from bootsupport plus those provided by running interp [info nameofexecutable]" + puts stdout $sep + puts stdout "- tcl::tm::list" + foreach fld [tcl::tm::list] { + if {[file exists $fld]} { + puts stdout " $fld" + } else { + #puts stdout " $fld (not present)" + } + } + puts stdout "- auto_path" + foreach fld $::auto_path { + if {[file exists $fld]} { + puts stdout " $fld" + } else { + #puts stdout " $fld (not present)" + } + } + set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] + foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { + lassign $pkg_request pkgname vrequest + catch {package require $pkgname {*}$vrequest} ;#todo + } + flush stderr + #punk::lib::showdict -channel stderr $::punkboot::pkg_availability + set missing_out [::punkboot::get_display_missing_packages $::punkboot::pkg_availability] + puts stdout $missing_out\n + set broken_out [::punkboot::get_display_broken_packages $::punkboot::pkg_availability] + puts stdout $broken_out + puts stdout $sep + puts stdout $sep + catch {package require struct::set} + puts stdout ---[package ifneeded struct::set 2.2.3] + exit 0 } +dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { + set verspec [dict get $pkginfo version] ;#version wanted specification always exists and is empty or normalised + if {[catch {package require $pkg {*}$verspec} errM]} { + puts stdout "\x1b\[33m$errM\x1b\[m" + } +} -if {$::punkmake::command eq "info"} { +if {$::punkboot::command eq "info"} { puts stdout "- -- --- --- --- --- --- --- --- --- -- -" puts stdout "- -- info -- -" puts stdout "- -- --- --- --- --- --- --- --- --- -- -" @@ -277,22 +1283,22 @@ if {$::punkmake::command eq "info"} { set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] puts stdout "- vendorlib folders: ([llength $vendorlibfolders])" foreach fld $vendorlibfolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } puts stdout "- vendormodule folders: ([llength $vendormodulefolders])" foreach fld $vendormodulefolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] puts stdout "- source module paths: [llength $source_module_folderlist]" foreach fld $source_module_folderlist { - puts stdout " $fld" + puts stdout " $fld" } set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] lappend projectlibfolders lib puts stdout "- source libary paths: [llength $projectlibfolders]" foreach fld $projectlibfolders { - puts stdout " src/$fld" + puts stdout " src/$fld" } if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { set vc "fossil" @@ -318,34 +1324,41 @@ if {$::punkmake::command eq "info"} { exit 0 } -if {$::punkmake::command eq "shell"} { + + + +if {$::punkboot::command eq "shell"} { package require punk package require punk::repl - puts stderr "make shell not fully implemented - dropping into ordinary punk shell" + puts stderr "punk boot shell not implemented - dropping into ordinary punk shell" + + #todo - make procs vars etc from this file available? + + repl::init repl::start stdin exit 1 } -if {$::punkmake::command eq "vfscommonupdate"} { +if {$::punkboot::command eq "vfscommonupdate"} { puts "projectroot: $projectroot" puts "script: [info script]" - puts stdout "Updating vfs/_vfscommon" + puts stdout "Updating vfs/_vfscommon.vfs" - puts stdout "REPLACE src/vfs/_vfscommon/* with project's modules and libs?? y|n" + puts stdout "REPLACE src/vfs/_vfscommon.vfs/* with project's modules and libs?? y|n" if {[gets stdin] eq "y"} { puts proceeding... proc vfscommonupdate {projectroot} { - file delete -force $projectroot/src/vfs/_vfscommon/modules - file copy $projectroot/modules $projectroot/src/vfs/_vfscommon/ + file delete -force $projectroot/src/vfs/_vfscommon.vfs/modules + file copy $projectroot/modules $projectroot/src/vfs/_vfscommon.vfs/ #temp? (avoid zipfs mkimg windows dotfile bug) - file delete $projectroot/src/vfs/_vfscommon/modules/.punkcheck + file delete $projectroot/src/vfs/_vfscommon.vfs/modules/.punkcheck - file delete -force $projectroot/src/vfs/_vfscommon/lib - file copy $projectroot/lib $projectroot/src/vfs/_vfscommon/ + file delete -force $projectroot/src/vfs/_vfscommon.vfs/lib + file copy $projectroot/lib $projectroot/src/vfs/_vfscommon.vfs/ #temp? - file delete $projectroot/src/vfs/_vfscommon/lib/.punkcheck + file delete $projectroot/src/vfs/_vfscommon.vfs/lib/.punkcheck } vfscommonupdate $projectroot @@ -362,7 +1375,7 @@ if {$::punkmake::command eq "vfscommonupdate"} { ::exit 0 } -if {$::punkmake::command eq "vendorupdate"} { +if {$::punkboot::command eq "vendorupdate"} { puts "projectroot: $projectroot" puts "script: [info script]" #puts "-- [tcl::tm::list] --" @@ -376,10 +1389,9 @@ if {$::punkmake::command eq "vendorupdate"} { #todo vendor/lib set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] - set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] - lappend vendormodulefolders vendormodules + set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] + #lappend vendormodulefolders vendormodules foreach vf $vendormodulefolders { - if {[file exists $sourcefolder/$vf]} { lassign [split $vf _] _vm tclx if {$tclx ne ""} { set which _$tclx @@ -404,6 +1416,7 @@ if {$::punkmake::command eq "vendorupdate"} { puts stderr "Unable to use punkcheck for vendormodules$which update. Error: $errM" set installation_event "" } + #todo - sync alg with bootsupport_localupdate! foreach {relpath requested_module} $local_modules { set requested_module [string trim $requested_module :] set module_subpath [string map {:: /} [namespace qualifiers $requested_module]] @@ -467,7 +1480,6 @@ if {$::punkmake::command eq "vendorupdate"} { } else { puts stderr "No config at $vendor_config - nothing configured to update" } - } } } @@ -479,68 +1491,79 @@ if {$::punkmake::command eq "vendorupdate"} { ::exit 0 } -if {$::punkmake::command eq "bootsupport"} { +if {$::punkboot::command eq "bootsupport"} { puts "projectroot: $projectroot" puts "script: [info script]" #puts "-- [tcl::tm::list] --" puts stdout "Updating bootsupport from local files" + proc modfile_sort {p1 p2} { + lassign [split [file rootname $p1] -] _ v1 + lassign [split [file rootname $p1] -] _ v2 + package vcompare $v1 $v2 + } proc bootsupport_localupdate {projectroot} { set bootsupport_modules [list] ;#variable populated by include_modules.config file - review set sourcefolder $projectroot/src - set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules_tcl*] - lappend bootmodulefolders modules + set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules modules_tcl*] foreach bm $bootmodulefolders { - if {[file exists $sourcefolder/bootsupport/$bm]} { - lassign [split $bm _] _bm tclx - if {$tclx ne ""} { - set which _$tclx + lassign [split $bm _] _bm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# + if {[file exists $bootsupport_config]} { + set targetroot $projectroot/src/bootsupport/modules$which + source $bootsupport_config ;#populate $bootsupport_modules with project-specific list + if {![llength $bootsupport_modules]} { + puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" } else { - set which "" - } - set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# - if {[file exists $bootsupport_config]} { - set targetroot $projectroot/src/bootsupport/modules$which - source $bootsupport_config ;#populate $bootsupport_modules with project-specific list - if {![llength $bootsupport_modules]} { - puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" - } else { - if {[catch { - #---------- - set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] - $boot_installer set_source_target $projectroot $projectroot/src/bootsupport - set boot_event [$boot_installer start_event {-make_step bootsupport}] - #---------- - } errM]} { - puts stderr "Unable to use punkcheck for bootsupport error: $errM" - set boot_event "" + if {[catch { + #---------- + set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] + $boot_installer set_source_target $projectroot $projectroot/src/bootsupport + set boot_event [$boot_installer start_event {-make_step bootsupport}] + #---------- + } errM]} { + puts stderr "Unable to use punkcheck for bootsupport error: $errM" + set boot_event "" + } + + foreach {relpath modulematch} $bootsupport_modules { + set modulematch [string trim $modulematch :] + set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $modulematch $module_subpath $srclocation" + if {[string first - $modulematch]} { + set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm] + } else { + set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm] + } + if {![llength $pkgmatches]} { + puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation" + continue } - foreach {relpath module} $bootsupport_modules { - set module [string trim $module :] - set module_subpath [string map [list :: /] [namespace qualifiers $module]] - set srclocation [file join $projectroot $relpath $module_subpath] - #puts stdout "$relpath $module $module_subpath $srclocation" - set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] - #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 - if {![llength $pkgmatches]} { - puts stderr "Missing source for bootsupport module $module - not found in $srclocation" - continue - } - set latestfile [lindex $pkgmatches 0] - set latestver [lindex [split [file rootname $latestfile] -] 1] - foreach m $pkgmatches { - lassign [split [file rootname $m] -] _pkg ver - #puts "comparing $ver vs $latestver" - if {[package vcompare $ver $latestver] == 1} { - set latestver $ver - set latestfile $m - } - } - set srcfile [file join $srclocation $latestfile] - set tgtfile [file join $targetroot $module_subpath $latestfile] + set modulematch_is_glob [regexp {[*?\[\]]} $modulematch] + if {!$modulematch_is_glob} { + #if modulematch was specified without globs - only copy latest + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func + set pkgmatches [lsort -command modfile_sort $pkgmatches] + set latestfile [lindex $pkgmatches end] + #set latestver [lindex [split [file rootname $latestfile] -] 1] + set copy_files $latestfile + } else { + #globs in modulematch - may be different packages matched by glob - copy all versions of matches + #review + set copy_files $pkgmatches + } + foreach cfile $copy_files { + set srcfile [file join $srclocation $cfile] + set tgtfile [file join $targetroot $module_subpath $cfile] if {$boot_event ne ""} { #---------- $boot_event targetset_init INSTALL $tgtfile @@ -571,14 +1594,14 @@ if {$::punkmake::command eq "bootsupport"} { file copy -force $srcfile $tgtfile } } - if {$boot_event ne ""} { - puts \n - $boot_event destroy - $boot_installer destroy - } } - + if {$boot_event ne ""} { + puts \n + $boot_event destroy + $boot_installer destroy + } } + } } } @@ -594,13 +1617,14 @@ if {$::punkmake::command eq "bootsupport"} { if {[file exists $project_layout_base]} { set project_layouts [glob -nocomplain -dir $project_layout_base -type d -tail *] foreach layoutname $project_layouts { + puts stdout "Processing layout $project_layout_base/$layoutname" #don't auto-create src/bootsupport - just update it if it exists if {[file exists [file join $project_layout_base $layoutname/src/bootsupport]]} { set antipaths [list\ README.md\ ] - set boot_module_folders [glob -nocomplain -dir $projectroot/src/bootsupport/modules_tcl*] - lappend bootsupport_module_folders "modules" + #set boot_module_folders [list modules {*}[glob -nocomplain -dir $projectroot/src/bootsupport/modules_tcl*]] + set bootsupport_module_folders "modules" foreach bm $bootsupport_module_folders { if {[file exists $projectroot/src/bootsupport/$bm]} { lassign [split $bm _] _bm tclx @@ -614,12 +1638,33 @@ if {$::punkmake::command eq "bootsupport"} { file mkdir $targetroot puts stdout "BOOTSUPPORT$which layouts/$layoutname: copying from $sourcemodules to $targetroot (if source file changed)" - set resultdict [punkcheck::install $sourcemodules $targetroot -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + + set resultdict [punkcheck::install $sourcemodules $targetroot\ + -overwrite installedsourcechanged-targets\ + -antiglob_paths $antipaths\ + -installer "punkboot-bootsupport" + ] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] flush stdout } } } + #make.tcl (to be boot.tcl?) is part of bootsupport + set source_bootscript [file join $projectroot src/make.tcl] + set targetroot_bootscript $project_layout_base/$layoutname/src + if {[file exists $source_bootscript]} { + puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $source_bootscript to $targetroot_bootscript (if source file changed)" + set resultdict [punkcheck::install [file dirname $source_bootscript] $targetroot_bootscript\ + -glob make.tcl\ + -max_depth 1\ + -createempty 0\ + -overwrite installedsourcechanged-targets\ + -installer "punkboot-bootsupport" + ] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + flush stdout + } } } else { puts stderr "No layout base at $project_layout_base" @@ -635,8 +1680,8 @@ if {$::punkmake::command eq "bootsupport"} { -if {$::punkmake::command ni {project modules}} { - puts stderr "Command $::punkmake::command not implemented - aborting." +if {$::punkboot::command ni {project modules vfs}} { + puts stderr "Command $::punkboot::command not implemented - aborting." flush stderr after 100 exit 1 @@ -648,10 +1693,9 @@ if {$::punkmake::command ni {project modules}} { #install src vendor contents (from version controlled src folder) to base of project (same target folders as our own src/modules etc ie to paths that go on the auto_path and in tcl::tm::list) -set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] -lappend vendorlibfolders vendorlib -foreach lf $vendorlibfolders { - if {[file exists $sourcefolder/$lf]} { +if {$::punkboot::command in {project modules}} { + set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib vendorlib_tcl*] + foreach lf $vendorlibfolders { lassign [split $lf _] _vm tclx if {$tclx ne ""} { set which _$tclx @@ -672,16 +1716,12 @@ foreach lf $vendorlibfolders { set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } -} -if {![llength $vendorlibfolders]} { - puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." -} - -set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] -lappend vendormodulefolders vendormodules + if {![llength $vendorlibfolders]} { + puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." + } -foreach vf $vendormodulefolders { - if {[file exists $sourcefolder/$vf]} { + set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] + foreach vf $vendormodulefolders { lassign [split $vf _] _vm tclx if {$tclx ne ""} { set which _$tclx @@ -696,83 +1736,81 @@ foreach vf $vendormodulefolders { set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } -} -if {![llength $vendormodulefolders]} { - puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found." -} - -######################################################## -#templates -#e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync -#src to src/modules/punk/mix/templates/layouts/project/src - -set old_layout_update_list [list\ - [list project $sourcefolder/modules/punk/mix/templates]\ - [list basic $sourcefolder/mixtemplates]\ - ] -set layout_bases [list\ - $sourcefolder/project_layouts/custom/_project\ - ] - -foreach layoutbase $layout_bases { - if {![file exists $layoutbase]} { - continue + if {![llength $vendormodulefolders]} { + puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found." } - set project_layouts [glob -nocomplain -dir $layoutbase -type d -tail *] - foreach layoutname $project_layouts { - set config [dict create\ - -make-step sync_layouts\ + + ######################################################## + #templates + #e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync + #src to src/modules/punk/mix/templates/layouts/project/src + + set old_layout_update_list [list\ + [list project $sourcefolder/modules/punk/mix/templates]\ + [list basic $sourcefolder/mixtemplates]\ ] - #---------- - set tpl_installer [punkcheck::installtrack new make.tcl $layoutbase/.punkcheck] - $tpl_installer set_source_target $sourcefolder $layoutbase - set tpl_event [$tpl_installer start_event $config] - #---------- - set pairs [list] - set pairs [list\ - [list $sourcefolder/build.tcl $layoutbase/$layoutname/src/build.tcl]\ - [list $sourcefolder/make.tcl $layoutbase/$layoutname/src/make.tcl]\ + set layout_bases [list\ + $sourcefolder/project_layouts/custom/_project\ ] - foreach filepair $pairs { - lassign $filepair srcfile tgtfile - - file mkdir [file dirname $tgtfile] + foreach layoutbase $layout_bases { + if {![file exists $layoutbase]} { + continue + } + set project_layouts [glob -nocomplain -dir $layoutbase -type d -tail *] + foreach layoutname $project_layouts { + set config [dict create\ + -make-step sync_layouts\ + ] #---------- - $tpl_event targetset_init INSTALL $tgtfile - $tpl_event targetset_addsource $srcfile + set tpl_installer [punkcheck::installtrack new make.tcl $layoutbase/.punkcheck] + $tpl_installer set_source_target $sourcefolder $layoutbase + set tpl_event [$tpl_installer start_event $config] #---------- - if {\ - [llength [dict get [$tpl_event targetset_source_changes] changed]]\ - || [llength [$tpl_event get_targets_exist]] < [llength [$tpl_event get_targets]]\ - } { - $tpl_event targetset_started - # -- --- --- --- --- --- - puts stdout "PROJECT LAYOUT update - layoutname: $layoutname Copying from $srcfile to $tgtfile" - if {[catch { - file copy -force $srcfile $tgtfile - } errM]} { - $tpl_event targetset_end FAILED -note "layout:$layoutname copy failed with err: $errM" + set pairs [list] + set pairs [list\ + [list $sourcefolder/build.tcl $layoutbase/$layoutname/src/build.tcl]\ + [list $sourcefolder/make.tcl $layoutbase/$layoutname/src/make.tcl]\ + ] + + foreach filepair $pairs { + lassign $filepair srcfile tgtfile + + file mkdir [file dirname $tgtfile] + #---------- + $tpl_event targetset_init INSTALL $tgtfile + $tpl_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$tpl_event targetset_source_changes] changed]]\ + || [llength [$tpl_event get_targets_exist]] < [llength [$tpl_event get_targets]]\ + } { + $tpl_event targetset_started + # -- --- --- --- --- --- + puts stdout "PROJECT LAYOUT update - layoutname: $layoutname Copying from $srcfile to $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $tpl_event targetset_end FAILED -note "layout:$layoutname copy failed with err: $errM" + } else { + $tpl_event targetset_end OK -note "layout:$layoutname" + } + # -- --- --- --- --- --- } else { - $tpl_event targetset_end OK -note "layout:$layoutname" + puts stderr "." + $tpl_event targetset_end SKIPPED } - # -- --- --- --- --- --- - } else { - puts stderr "." - $tpl_event targetset_end SKIPPED } - } - $tpl_event end - $tpl_event destroy - $tpl_installer destroy + $tpl_event end + $tpl_event destroy + $tpl_installer destroy + } } -} -######################################################## -set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] -lappend projectlibfolders lib -foreach lf $projectlibfolders { - if {[file exists $sourcefolder/$lf]} { + ######################################################## + set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] + lappend projectlibfolders lib + foreach lf $projectlibfolders { lassign [split $lf _] _vm tclx if {$tclx ne ""} { set which _$tclx @@ -793,88 +1831,91 @@ foreach lf $projectlibfolders { set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } -} -if {![llength $projectlibfolders]} { - puts stderr "PROJECTLIB: No src/lib or src/lib_tcl* folder found." -} + if {![llength $projectlibfolders]} { + puts stderr "PROJECTLIB: No src/lib or src/lib_tcl* folder found." + } -#consolidated /modules /modules_tclX folder used for target where X is tcl major version -#the make process will process for any _tclX not just the major version of the current interpreter - -#default source module folders are at projectroot/src/modules and projectroot/src/modules_tclX (where X is tcl major version) -#There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root) -set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] -puts stdout "SOURCEMODULES: scanning [llength $source_module_folderlist] folders" -foreach src_module_dir $source_module_folderlist { - set mtail [file tail $src_module_dir] - if {[string match "modules_tcl*" $mtail]} { - set target_modules_base $projectroot/$mtail - } else { - set target_modules_base $projectroot/modules - } - file mkdir $target_modules_base - - puts stderr "Processing source module dir: $src_module_dir" - set dirtail [file tail $src_module_dir] - #modules and associated files belonging to this package/app - set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm - #set copied [list] - puts stdout "--------------------------" - puts stderr "Copied [llength $copied] tm modules from src/$dirtail to $target_modules_base " - puts stdout "--------------------------" - - set overwrite "installedsourcechanged-targets" - #set overwrite "ALL-TARGETS" - puts stdout "MODULEFOLDER non_tm_files $src_module_dir - copying to $target_modules_base (if source file changed)" - set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base -installer make.tcl -overwrite $overwrite -antiglob_paths {README.md}] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] -} + #consolidated /modules /modules_tclX folder used for target where X is tcl major version + #the make process will process for any _tclX not just the major version of the current interpreter -set installername "make.tcl" + #default source module folders are at projectroot/src/modules and projectroot/src/modules_tclX (where X is tcl major version) + #There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root) + set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] + puts stdout "SOURCEMODULES: scanning [llength $source_module_folderlist] folders" + foreach src_module_dir $source_module_folderlist { + set mtail [file tail $src_module_dir] + if {[string match "modules_tcl*" $mtail]} { + set target_modules_base $projectroot/$mtail + } else { + set target_modules_base $projectroot/modules + } + file mkdir $target_modules_base + + puts stderr "Processing source module dir: $src_module_dir" + set dirtail [file tail $src_module_dir] + #modules and associated files belonging to this package/app + set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm + #set copied [list] + puts stdout "--------------------------" + puts stderr "Copied [llength $copied] tm modules from src/$dirtail to $target_modules_base " + puts stdout "--------------------------" + + set overwrite "installedsourcechanged-targets" + #set overwrite "ALL-TARGETS" + puts stdout "MODULEFOLDER non_tm_files $src_module_dir - copying to $target_modules_base (if source file changed)" + set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base -installer make.tcl -overwrite $overwrite -antiglob_paths {README.md}] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } -# ---------------------------------------- -if {[punk::repo::is_fossil_root $projectroot]} { - set config [dict create\ - -make-step configure_fossil\ - ] - #---------- - set installer [punkcheck::installtrack new $installername $projectroot/.punkcheck] - $installer set_source_target $projectroot $projectroot + set installername "make.tcl" - set event [$installer start_event $config] - $event targetset_init VIRTUAL fossil_settings_mainmenu ;#VIRTUAL - since there is no actual target file - set menufile $projectroot/.fossil-custom/mainmenu - $event targetset_addsource $menufile - #---------- + # ---------------------------------------- + if {[punk::repo::is_fossil_root $projectroot]} { + set config [dict create\ + -make-step configure_fossil\ + ] + #---------- + set installer [punkcheck::installtrack new $installername $projectroot/.punkcheck] + $installer set_source_target $projectroot $projectroot - if {\ - [llength [dict get [$event targetset_source_changes] changed]]\ - } { - $event targetset_started - # -- --- --- --- --- --- - puts stdout "Configuring fossil setting: mainmenu from: $menufile" - if {[catch { - set fd [open $menufile r] - fconfigure $fd -translation binary - set data [read $fd] - close $fd - exec fossil settings mainmenu $data - } errM]} { - $event targetset_end FAILED -note "fossil update failed: $errM" + set event [$installer start_event $config] + $event targetset_init VIRTUAL fossil_settings_mainmenu ;#VIRTUAL - since there is no actual target file + set menufile $projectroot/.fossil-custom/mainmenu + $event targetset_addsource $menufile + #---------- + + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + } { + $event targetset_started + # -- --- --- --- --- --- + puts stdout "Configuring fossil setting: mainmenu from: $menufile" + if {[catch { + set fd [open $menufile r] + fconfigure $fd -translation binary + set data [read $fd] + close $fd + exec fossil settings mainmenu $data + } errM]} { + $event targetset_end FAILED -note "fossil update failed: $errM" + } else { + $event targetset_end OK + } + # -- --- --- --- --- --- } else { - $event targetset_end OK + puts stderr "." + $event targetset_end SKIPPED } - # -- --- --- --- --- --- - } else { - puts stderr "." - $event targetset_end SKIPPED + $event end + $event destroy + $installer destroy } - $event end - $event destroy - $installer destroy } -if {$::punkmake::command ne "project"} { +#review +set installername "make.tcl" + +if {$::punkboot::command ni {project vfs}} { #command = modules puts stdout "vfs folders not checked" puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into base vfs folder" @@ -1027,6 +2068,13 @@ foreach runtime [dict keys $runtime_vfs_map] { dict set caps has_zipfs 0 } } errM]} + if {![catch { + package require cookfs + } errM]} { + dict set caps has_cookfs 1 + } else { + dict set caps has_cookfs 0 + } puts -nonewline stdout $caps exit 0 } @@ -1090,9 +2138,10 @@ foreach runtimefile $runtimes { } { $event targetset_started # -- --- --- --- --- --- - puts stdout "Copying runtime from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" + #This is the full runtime - *possibly* with some sort of vfs attached. + puts stdout "Copying runtime (as is) from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" if {[catch { - file copy -force $rtfolder/$runtimefile $buildfolder/build_$runtimefile + file copy -force $rtfolder/$runtimefile $buildfolder/build_$runtimefile ;#becomes building_runtime } errM]} { puts stderr " >> copy runtime to $buildfolder/build_$runtimefile FAILED" $event targetset_end FAILED @@ -1101,7 +2150,7 @@ foreach runtimefile $runtimes { } # -- --- --- --- --- --- } else { - puts stderr "." + puts stderr "unchanged: $runtimefile" $event targetset_end SKIPPED } $event end @@ -1117,20 +2166,27 @@ set skipped_kit_installs [list] proc ::make_file_traversal_error {args} { error "file_traverse error: $args" } -proc merge_over {sourcedir targetdir} { + +#fauxlink aware recursive copy of files and folders +#will follow fauxlinks with 'merge_over' tag, will copy other fauxlinks +proc merge_over {sourcedir targetdir {depth 0}} { package require fileutil - package require fileutil::traverse + package require fauxlink + set margin [string repeat " " [expr {$depth * 4}]] + + set ver [package require fileutil::traverse] + puts stdout "${margin}using fileutil::traverse $ver\n[package ifneeded fileutil::traverse $ver]" package require control if {![file exists $sourcedir]} { - puts stderr "merge_over sourcedir '$sourcedir' not found" + puts stderr "${margin}merge_over sourcedir '$sourcedir' not found" return } if {![file exists $targetdir]} { - puts stderr "merge_over targetdir '$targetdir' not found - target folder must already exist" + puts stderr "${margin}merge_over targetdir '$targetdir' not found - target folder must already exist" return } - puts stdout "merge vfs $sourcedir over $targetdir STARTING" + puts stdout "${margin}merge vfs $sourcedir over $targetdir STARTING" #The tails should be unique enough for clarity in progress emissions to stdout set sourcename [file tail $sourcedir] @@ -1149,25 +2205,83 @@ proc merge_over {sourcedir targetdir} { } if {![file exists $target]} { #puts stdout "-- mkdir $target" - puts stdout "$sourcename -> $targetname mkdir $relpath" + puts stdout "${margin}$sourcename -> $targetname mkdir $relpath" + #puts stdout "calling: file mkdir $target" + #note - file mkdir can fail on vfs mounts with non-existant intermediate paths. + #e.g if mount is at: //cookfstemp:/subpath/file.exe + #if mounted lower, e.g //cookfstemp:/file.exe it works + #todo - determine where the bug lies - submit ticket? file mkdir $target file mtime $target [file mtime $file_or_dir] } else { - puts stdout "$sourcename -> $targetname existing dir $relpath" + puts stdout "${margin}$sourcename -> $targetname existing dir $relpath" } } file { - puts -nonewline stdout "." - file copy -force $file_or_dir $target + if {[file extension $file_or_dir] in {.fxlnk .fauxlink}} { + puts stdout "fauxlink: $file_or_dir" + flush stdout + if {[catch { + puts stdout ">";flush stdout + set linkinfo [fauxlink::resolve $file_or_dir] + } errM]} { + puts stdout ">>";flush stdout + puts stdout "${margin}--->fauxlink::resolve error\n $errM" + flush stdout + error $errM + } + puts stdout ">>>";flush stdout + puts stdout "--- '$linkinfo'" + flush stdout + set flinktags [dict get $linkinfo tags] + puts stdout "fauxlink tags: $flinktags" + flush stdout + if {"punk::boot,merge_over" in $flinktags} { + puts stdout "fauxlink got correct tag from $flinktags" + flush stdout + set linktarget [dict get $linkinfo targetpath] + if {[file pathtype $linktarget] eq "relative"} { + set actualsource [file join $sourcedir $linktarget] + } else { + set actualsource $linktarget + } + set name [dict get $linkinfo name] ;#name the linked file will become + set aliased_file_or_dir [file join [file dirname $file_or_dir] $name] + set relpath [fileutil::stripPath $sourcedir $aliased_file_or_dir] + set target [file join $targetdir $relpath] + if {[file type $actualsource] eq "file"} { + #fauxlink linktarget (source data) is a file + puts -nonewline stdout "\x1b\[32m\x1b\[m" + #puts "file copy -force $actualsource $target" + file copy -force $actualsource $target + } else { + #fauxlink linktarget (source data) is a folder + puts stdout "${margin}RECURSING merge_over for link-target $actualsource due to fauxlink:[file tail $file_or_dir]" + #merge_over initial target dir must exist - use file mkdir to ensure + file mkdir $target + puts stdout "merge_over $actualsource $target [expr {$depth + 1}]" + merge_over $actualsource $target [expr {$depth + 1}] + } + } else { + puts stdout "fauxlink tag not matched" + flush stdout + #tag not targetted at us - just copy the fauxlink as an ordinary file + puts -nonewline stdout "" + file copy -force $file_or_dir $target + } + } else { + puts -nonewline stdout "." + file copy -force $file_or_dir $target + } } default { - puts stderr "merge vfs $sourcedir !!! unhandled file type $this_type !!!" + puts stderr "${margin}merge vfs $sourcedir !!! unhandled file type $this_type !!!" } } set last_type $this_type } $t destroy - puts stdout "\nmerge vfs $sourcedir over $targetdir done." + puts stdout "\n${margin}merge vfs $sourcedir over $targetdir done." } set startdir [pwd] puts stdout "Found [llength $vfs_tails] .vfs folders - checking each for executables that may need to be built" @@ -1178,7 +2292,7 @@ cd [file dirname $buildfolder] #Using first mtime encountered that is later than target is another option - but likely to be highly variable in speed. Last file in the tree could happen to be the latest, and this mechanism doesn't handle build on reversion to older source. set exe_names_seen [list] set path_cksum_cache [dict create] -dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/_vfscommon] +dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/_vfscommon.vfs] # # loop over vfs_tails and for each one, loop over configured (or matching) runtimes - build with sdx or zipfs if source .vfs or source runtime exe has changed. @@ -1227,7 +2341,7 @@ foreach vfstail $vfs_tails { } else { lappend runtimes $matchrt } - } + } } #assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config @@ -1290,14 +2404,19 @@ foreach vfstail $vfs_tails { dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/$vfstail] } $vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder - $vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon + $vfs_event targetset_addsource $sourcefolder/vfs/_config ;#some files linked via fauxlink - need to detect change + $vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon.vfs $vfs_event targetset_addsource $sourcefolder/vfs/$vfstail if {$rtname ne "-"} { - $vfs_event targetset_addsource $buildfolder/build_$runtime_fullname ;#working copy of runtime executable + set building_runtime $buildfolder/build_$runtime_fullname ;#working copy of runtime executable - (possibly with kit/zipfs/cookfs etc attached!) + $vfs_event targetset_addsource $building_runtime + set raw_runtime "" ;#building runtime with vfs (zip,kit,cookfs etc stripped) + } else { + set building_runtime "-" ;#REVIEW + set raw_runtime "-" } # -- ---------- - set rtmountpoint //zipfs:/rtmounts/$runtime_fullname set changed_unchanged [$vfs_event targetset_source_changes] set vfs_or_runtime_changed [expr {[llength [dict get $changed_unchanged changed]] || [llength [$vfs_event get_targets_exist]] < [llength [$vfs_event get_targets]]}] @@ -1316,37 +2435,112 @@ foreach vfstail $vfs_tails { package require fileutil::traverse package require control - set targetvfs $buildfolder/buildvfs_$targetkit.vfs + #keep this a simple name - bin/punk script calls into src/_build/exename.vfs/main.tcl + set targetvfs $buildfolder/$targetkit.vfs file delete -force $targetvfs + #we switch on the target kit_type. we could switch on source kit_type..allowing extraction from one type but writing to another? + #it usually won't make sense to try to convert a runtime kit_type to another - unless the runtime happens to support multiple types - + # - but which location would main.tcl be run from? + #todo - check runtime's 'kit_type' and warn/disallow. + #to consider: - allow specifying runtime kits as if they are vfs folders in the normal xxx.vfs list - and autodetect and extract + #would need to detect UPX, cookfs,zipfs,tclkit + set rtmountpoint "" switch -- $kit_type { - zip { + zip - zipcat { #for a zipkit - we need to extract the existing vfs from the runtime #zipfs mkimg replaces the entire zipped vfs in the runtime - so we need the original data to be part of our targetvfs. puts stdout "building $vfsname.new with zipfs vfsdir:$vfstail cwd: [pwd]" file mkdir $targetvfs + set rtmountpoint //zipfs:/rtmounts/$runtime_fullname if {![file exists $rtmountpoint]} { if {[catch { - tcl::zipfs::mount $buildfolder/build_$runtime_fullname rtmounts/$runtime_fullname + tcl::zipfs::mount $building_runtime rtmounts/$runtime_fullname } errM]} { - tcl::zipfs::mount rtmounts/$runtime_fullname $buildfolder/build_$runtime_fullname + puts stderr "Failed to mount $building_runtime using standard api. Err:$errM\n trying reverse args on tcl::zipfs::mount..." + if {[catch { + tcl::zipfs::mount rtmounts/$runtime_fullname $building_runtime + } errM]} { + puts stderr "ALSO Failed to mount $building_runtime using reverse args to api. Err:$errM - no mountable zipfs on runtime?" + } } } + #strip any existing zipfs on the runtime.. + #2024 - 'zipfs info //zipfs:/mountpoint' is supposed to give us the offset - but it doesn't if the exe has been 'adjusted' to use file offsets. + #which unfortunately Tcl does by default after the 2021 'fix' :( + #https://core.tcl-lang.org/tcl/tktview/aaa84fbbc5 + + set raw_runtime $buildfolder/raw_$runtime_fullname if {[file exists $rtmountpoint]} { merge_over $rtmountpoint $targetvfs + #see if we can extract the exe part + set baseoffset [lindex [tcl::zipfs::info $rtmountpoint] 3] + if {$baseoffset != 0} { + #tcl was able to determine the compressed-data offset + #either because runtime is a basic catted exe+zip, or Tcl fixed 'zipfs info' + set fdrt [open $building_runtime r] + chan configure $fdrt -translation binary + set exedata [read $fdrt $baseoffset] ;#may include stored password and ending header // REVIEW - strip it? + close $fdrt + set fdraw [open $raw_runtime w] + chan configure $fdraw -translation binary + puts -nonewline $fdraw $exedata + close $fdraw + } else { + #presumably the supplied building_runtime has had its offsets adjusted so that it all appears within offsets off the zip. (file relative offsets) + #due to zipfs info bug - zipfs now can't tell us the offset of the compressed data. + #we need to use a similarly assumptive method as tclZipfs.c uses to determine the start of the compressed contents + package require punk::zip + #we don't technically need to extract the raw exe for 'zip' - as zipfs mkimg can work on the combined file (ignores zip) + # - but for consistency we want raw_runtime to be emitted in the filesystem. + punk::zip::extract_preamble $building_runtime $raw_runtime + } + } else { + #the input building_runtime wasn't mountable - so presumably a plain executable + #set building_runtime $buildfolder/build_$runtime_fullname ;#working copy of runtime executable - (possibly with kit/zipfs/cookfs etc attached!) + #set raw_runtime $buildfolder/raw_$runtime_fullname + file copy -force $building_runtime $raw_runtime } - merge_over $sourcefolder/vfs/_vfscommon $targetvfs + merge_over $sourcefolder/vfs/_vfscommon.vfs $targetvfs } + cookit - cookfs { + #upx easy enough to deal with if we have/install a upx executable (avail on windows via scoop, freshports for freebsd and presumably various for linux) + # ------------------------------------------------------ + #we can't use cookfs with arbitrary tclsh/kits etc yet.. + # ------------------------------------------------------ + #cookfs seems to need compilation - we would need to be able to build for windows,linux,freebsd at a minimum. + #preferably vi cross-compile using zig. + + #However, if our calling executable is also a cookit, or the user has cookfs package installed - we may have it available + if {[catch {package require cookfs} version]} { + puts stderr "cookit/cookvfs unsupported - unable to load cookfs" + puts stderr " - Try running make.tcl using a cookkit binary (e.g put it in /bin) or installing the tcl-cookfs module" + } else { + puts stdout "building $vfsname.new with cookfs.. vfsdir:$vfstail cwd: [pwd]" ;flush stdout + file mkdir $targetvfs + #Mount it in the currently running executable + #REVIEW - it seems to work to pick a pseudovol name like //cookfstemp:/ + #unlike cookit's //cookit:/ it doesn't show up in file volumes + #set rtmountpoint //cookfstemp:/rtmounts/$runtime_fullname ;#not writable with 'file mkdir' which doesn't seem to handle intermediate nonexistant path + set rtmountpoint //cookfstemp:/$runtime_fullname + cookfs::Mount $building_runtime $rtmountpoint + if {[file exists $rtmountpoint]} { + #copy from mounted runtime's vfs to the filesystem vfs + merge_over $rtmountpoint $targetvfs + } + merge_over $sourcefolder/vfs/_vfscommon.vfs $targetvfs + } + } kit { #for a kit, we don't need to extract the existing vfs from the runtime. # - the sdx merge process can merge our .vfs folder with the existing contents. puts stdout "building $vfsname.new with sdx.. vfsdir:$vfstail cwd: [pwd]" - if {[file exists $sourcefolder/vfs/_vfscommon]} { - file copy $sourcefolder/vfs/_vfscommon $targetvfs + if {[file exists $sourcefolder/vfs/_vfscommon.vfs]} { + file copy $sourcefolder/vfs/_vfscommon.vfs $targetvfs } else { file mkdir $targetvfs } @@ -1358,9 +2552,23 @@ foreach vfstail $vfs_tails { merge_over $sourcevfs $targetvfs #set wrapvfs $sourcefolder/$vfs + set wrapvfs $targetvfs switch -- $kit_type { zip { + #WARNING - 2024-10-08 - zipfs mkimg based exezips are not editable with 7z + # (central directory offset has been 'adjusted' to be file relative) + #This makes finding the split between prefixed exe and zip-data harder for Tcl scripts + #- although zipfs mkimg does it in a somewhat wonky way. + #tclZipfs.c as at 2024 assumes first file header in the CDR points to first local file header and assumes that is the top of the zipdata. + #This is only *mostly* true. order of entries or completeness is not guaranteed. + #e.g topmost file data in zip may not be pointed to if deleted by certain tools. + #for files created by zipfs mkimg and not externally edited - it shouldn't be an issue though. + + if {$rtname eq "-"} { + #todo - just make a zip? + error "runtime name of - unsupported for zip - (todo)" + } if {[catch { if {[dict exists $runtime_caps $rtname]} { if {[dict get $runtime_caps $rtname exitcode] == 0} { @@ -1373,8 +2581,8 @@ foreach vfstail $vfs_tails { } } #note - as at 2024-08 - there is some discussion about the interface to mkimg - it is considered unstable (may change to -option value syntax) - puts stderr "calling: tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs \"\" $buildfolder/build_$runtime_fullname" - tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs "" $buildfolder/build_$runtime_fullname + puts stderr "calling: tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs \"\" $raw_runtime" + tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs "" $raw_runtime } result ]} { set failmsg "zipfs mkimg failed with msg: $result" puts stderr "tcl::zipfs::mkimg $targetkit failed" @@ -1391,6 +2599,113 @@ foreach vfstail $vfs_tails { puts stdout $separator } } + zipcat { + #simple catenated runtime + zip - we need an exe runtime with no zipfs attached.. + if {$rtname eq "-"} { + #todo - just make a zip? + error "runtime name of - unsupported for zip - (todo)" + } + if {[catch { + if {[dict exists $runtime_caps $rtname]} { + if {[dict get $runtime_caps $rtname exitcode] == 0} { + if {![dict get $runtime_caps $rtname has_zipfs]} { + error "runtime $rtname doesn't have zipfs capability" + } + } else { + #could be runtime for another platform + puts stderr "RUNTIME capabilities unknown. Unsure if zip supported. trying anyway.." + } + } + + #'archive' based zip offsets - editable in 7z,peazip + file copy $raw_runtime $buildfolder/$vfsname.new + file delete $buildfolder/$vfsname.zip + + if {[info commands ::tcl::zipfs] ne ""} { + puts stdout "tcl::zipfs::mkzip $buildfolder/$vfsname.zip $wrapvfs $wrapvfs" + ::tcl::zipfs::mkzip $buildfolder/$vfsname.zip $wrapvfs $wrapvfs + } else { + puts stdout "punk::zip::mkzip -directory $wrapvfs -base $wrapvfs $buildfolder/$vfsname.zip *" + package require punk::zip + punk::zip::mkzip -directory $wrapvfs -base $wrapvfs $buildfolder/$vfsname.zip * + } + + + puts stderr "concatenating executable to zip.." + set fdout [open $buildfolder/$vfsname.new a] + chan conf $fdout -translation binary + puts stderr "runtime bytes: [tell $fdout]" + set fdzip [open $buildfolder/$vfsname.zip r] + chan conf $fdzip -translation binary + set zipbytes [fcopy $fdzip $fdout] + close $fdzip + puts stderr "zip bytes: $zipbytes" + puts stderr "exezip bytes: [tell $fdout]" + close $fdout + } result ]} { + set failmsg "creating zipcat image failed with msg: $result" + puts stderr "creating image (zipcat) $targetkit failed" + lappend failed_kits [list kit $targetkit reason $failmsg] + $vfs_event targetset_end FAILED + $vfs_event destroy + $vfs_installer destroy + continue + } else { + puts stdout "ok - finished zipcat image" + set separator [string repeat = 40] + puts stdout $separator + puts stdout $result + puts stdout $separator + } + + + } + cookit - cookfs { + if {$rtmountpoint eq ""} { + lappend failed_kits [list kit $targetkit reason mount_failed] + $vfs_event targetset_end FAILED + $vfs_event destroy + $vfs_installer destroy + continue + } else { + if {[catch { + #we still have the $building_runtime mounted + if {[catch { + merge_over $targetvfs $rtmountpoint + } errM]} { + puts stderr "$kit_type 'merge_over $targetvfs $rtmountpoint' failed\n$errM" + error $errM + } + if {[catch { + cookfs::Unmount $rtmountpoint + } errM]} { + puts stderr "$kit_type 'cookfs::Unmount $rtmountpoint' failed\n$errM" + error $errM + } + + #copy the version that is mounted in this runtime to vfsname.new + if {[catch { + file copy -force $building_runtime $buildfolder/$vfsname.new + } errM]} { + puts stderr "$kit_type 'file copy -force $building_runtime $buildfolder/$vfsname.new' failed\n$errM" + error $errM + } + } result]} { + puts stderr "Writing vfs data and opying cookfs file $building_runtime to $buildfolder/$vfsname.new failed\n $result" + lappend failed_kits [list kit $targetkit reason copy_failed] + $vfs_event targetset_end FAILED + $vfs_event destroy + $vfs_installer destroy + continue + } else { + puts stdout "ok - finished $kit_type" + set separator [string repeat = 40] + puts stdout $separator + puts stdout $result + puts stdout $separator + } + } + } kit { if {!$has_sdx} { puts stderr "no sdx available to wrap $targetkit" @@ -1400,17 +2715,20 @@ foreach vfstail $vfs_tails { $vfs_installer destroy continue } else { + set verbose "" + #set verbose "-verbose" + if {[catch { if {$rtname ne "-"} { - exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose + exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $building_runtime {*}$verbose } else { - exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose + exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs {*}$verbose } } result]} { if {$rtname ne "-"} { - set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose failed with msg: $result" + set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname {*}$verbose failed with msg: $result" } else { - set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose failed with msg: $result" + set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs {*}$verbose failed with msg: $result" } puts stderr "sdx wrap $targetkit failed" lappend failed_kits [list kit $targetkit reason $sdxmsg] @@ -1560,7 +2878,7 @@ foreach vfstail $vfs_tails { if {$built_or_installed_kit_changed} { if {[file exists $deployment_folder/$targetkit]} { - puts stderr "deleting existing deployed at $deployment_folder/$targetkit" + puts stderr "built or deployed kit changed - deleting existing deployed at $deployment_folder/$targetkit" if {[catch { file delete $deployment_folder/$targetkit } errMsg]} { @@ -1613,9 +2931,9 @@ set had_kits [expr {[llength $installed_kits] || [llength $failed_kits] || [llen if {$had_kits} { puts stdout " module builds and kit/zipkit builds processed (vfs config: src/runtime/mapvfs.config)" puts stdout " - use 'make.tcl modules' to build modules without scanning/building the vfs folders into executable kits/zipkits" - puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into the base vfs folder" - puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but" - puts stdout " without the latest built modules." + puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into the base vfs folder /src/vfs/_vfscommon.vfs" + puts stdout " - Note that without the vfscommonupdate step, 'make tcl vfs' (included in 'make tcl project') will build vfs based executables" + puts stdout " that include your current custom vfs folders in src/vfs, but with a _vfscommon.vfs that doesn't have the latest built modules" puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'" } else { puts stdout " module builds processed"