From 1ab0de6cefacc5d388a6d2dfd265fc3d7cf3ace9 Mon Sep 17 00:00:00 2001
From: Julian Noble <julian@precisium.com.au>
Date: Wed, 2 Apr 2025 05:07:20 +1100
Subject: [PATCH] update modules & vendormodules - netbox,tomlish + minor edits
in others
---
src/modules/punk-0.1.tm | 83 +-
src/modules/punk/ansi-999999.0a1.0.tm | 3 +-
.../cap/handlers/templates-999999.0a1.0.tm | 65 +-
src/modules/punk/config-0.1.tm | 972 +-
src/modules/punk/mix/base-0.1.tm | 5 +-
src/modules/punk/mix/cli-999999.0a1.0.tm | 20 +-
.../mix/commandset/buildsuite-999999.0a1.0.tm | 2 +-
.../punk/mix/commandset/debug-999999.0a1.0.tm | 8 +-
.../mix/commandset/module-999999.0a1.0.tm | 6 +-
.../mix/commandset/project-999999.0a1.0.tm | 170 +-
.../punk/mix/commandset/repo-999999.0a1.0.tm | 38 +-
.../templates/layouts/project/src/make.tcl | 15 +-
src/modules/punk/mod-0.1.tm | 327 +-
src/modules/punk/netbox-999999.0a1.0.tm | 15 +-
src/modules/punk/path-999999.0a1.0.tm | 21 +-
src/modules/punk/repl-999999.0a1.0.tm | 5 +-
src/modules/punk/repo-999999.0a1.0.tm | 240 +-
src/modules/punkapp-0.1.tm | 478 +-
src/modules/punkcheck-0.1.0.tm | 114 +-
src/vendormodules/commandstack-0.3.tm | 1028 +-
src/vendormodules/fauxlink-0.1.1.tm | 21 +-
src/vendormodules/include_modules.config | 1 +
src/vendormodules/metaface-1.2.5.tm | 12822 ++++++++--------
src/vendormodules/packageTest-0.1.1.tm | Bin 0 -> 11471 bytes
src/vendormodules/pattern-1.2.4.tm | 2570 ++--
src/vendormodules/patterncmd-1.2.4.tm | 1288 +-
src/vendormodules/patternpredator2-1.2.4.tm | 1508 +-
src/vendormodules/test/tomlish-1.1.1.tm | Bin 46279 -> 35335 bytes
src/vendormodules/test/tomlish-1.1.3.tm | Bin 0 -> 41457 bytes
src/vendormodules/tomlish-1.1.2.tm | 160 +-
.../{tomlish-1.1.1.tm => tomlish-1.1.3.tm} | 2110 ++-
31 files changed, 12640 insertions(+), 11455 deletions(-)
create mode 100644 src/vendormodules/packageTest-0.1.1.tm
create mode 100644 src/vendormodules/test/tomlish-1.1.3.tm
rename src/vendormodules/{tomlish-1.1.1.tm => tomlish-1.1.3.tm} (75%)
diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm
index 11d247a7..04efdc83 100644
--- a/src/modules/punk-0.1.tm
+++ b/src/modules/punk-0.1.tm
@@ -141,6 +141,7 @@ namespace eval punk {
}
if {[llength [file split $name]] != 1} {
+ #has a path
foreach ext $execExtensions {
set file ${name}${ext}
if {[file exists $file] && ![file isdirectory $file]} {
@@ -164,14 +165,20 @@ namespace eval punk {
}
foreach var {PATH Path path} {
- if {[info exists env($var)]} {
- append path ";$env($var)"
- }
+ if {[info exists env($var)]} {
+ append path ";$env($var)"
+ }
}
#change2
- set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}]
+ if {[file extension $name] ne "" && [string tolower [file extension $name]] in [string tolower $execExtensions]} {
+ set lookfor [list $name]
+ } else {
+ set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}]
+ }
+ #puts "-->$lookfor"
foreach dir [split $path {;}] {
+ set dir [string trim $dir {\\}] ;#trailing slash will result in a tail such as "/python.exe"
#set dir [file normalize $dir]
# Skip already checked directories
if {[info exists checked($dir)] || ($dir eq "")} {
@@ -179,6 +186,24 @@ namespace eval punk {
}
set checked($dir) {}
+ #surprisingly fast
+ #set matches [glob -nocomplain -dir $dir -types f -tails {*}$lookfor]
+ ##puts "--dir $dir matches:$matches"
+ #if {[llength $matches]} {
+ # set file [file join $dir [lindex $matches 0]]
+ # #puts "--match0:[lindex $matches 0] file:$file"
+ # return [set auto_execs($name) [list $file]]
+ #}
+
+ #what if it's a link?
+ #foreach match [glob -nocomplain -dir $dir -types f -tail {*}$lookfor] {
+ # set file [file join $dir $match]
+ # if {[file exists $file]} {
+ # return [set auto_execs($name) [list $file]]
+ # }
+ #}
+
+ #safest? could be a link?
foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] {
set file [file join $dir $match]
if {[file exists $file] && ![file isdirectory $file]} {
@@ -6775,31 +6800,36 @@ namespace eval punk {
}
+ punk::args::define {
+ @dynamic
+ @id -id ::punk::LOC
+ @cmd -name punk::LOC -help\
+ "LOC - lines of code.
+ An implementation of a notoriously controversial metric"
+ -return -default showdict -choices {dict showdict}
+ -dir -default "\uFFFF"
+ -exclude_dupfiles -default 1 -type boolean
+ ${[punk::args::resolved_def -types opts ::punk::path::treefilenames -antiglob_paths]}
+ -antiglob_files -default "" -type list -help\
+ "Exclude if file tail matches any of these patterns"
+ -exclude_punctlines -default 1 -type boolean
+ -show_largest -default 0 -type integer -help\
+ "Report the top largest linecount files.
+ The value represents the number of files
+ to report on."
+ } "
+ #we could map away whitespace and use string is punct - but not as flexible? review
+ -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
+ "
#An implementation of a notoriously controversial metric.
proc LOC {args} {
- set argspecs [subst {
- @dynamic
- @id -id ::punk::LOC
- @cmd -name punk::LOC -help\
- "LOC - lines of code.
- An implementation of a notoriously controversial metric"
- -dir -default "\uFFFF"
- -exclude_dupfiles -default 1 -type boolean
- ${[punk::args::resolved_def ::punk::path::treefilenames -antiglob_paths]}
- -exclude_punctlines -default 1 -type boolean
- -show_largest -default 0 -type integer -help\
- "Report the top largest linecount files.
- The value represents the number of files
- to report on."
- #we could map away whitespace and use string is punct - but not as flexible? review
- -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
- }]
- set argd [punk::args::get_dict $argspecs $args]
+ set argd [punk::args::parse $args withid ::punk::LOC]
lassign [dict values $argd] leaders opts values received
set searchspecs [dict values $values]
# -- --- --- --- --- ---
- set opt_dir [dict get $opts -dir]
+ set opt_return [dict get $opts -return]
+ set opt_dir [dict get $opts -dir]
if {$opt_dir eq "\uFFFF"} {
set opt_dir [pwd] ;#pwd can take over a ms on windows in a not terribly deep path even with SSDs - so as a general rule we don't use it in the original defaults list
}
@@ -6808,10 +6838,12 @@ namespace eval punk {
set opt_exclude_punctlines [dict get $opts -exclude_punctlines] ;#exclude lines that consist purely of whitespace and the chars in -punctchars
set opt_punctchars [dict get $opts -punctchars]
set opt_largest [dict get $opts -show_largest]
+ set opt_antiglob_paths [dict get $opts -antiglob_paths]
+ set opt_antiglob_files [dict get $opts -antiglob_files]
# -- --- --- --- --- ---
- set filepaths [punk::path::treefilenames -dir $opt_dir {*}$searchspecs]
+ set filepaths [punk::path::treefilenames -dir $opt_dir -antiglob_paths $opt_antiglob_paths -antiglob_files $opt_antiglob_files {*}$searchspecs]
set loc 0
set dupfileloc 0
set seentails [dict create]
@@ -6941,6 +6973,9 @@ namespace eval punk {
}
dict set result largest $largest_n
}
+ if {$opt_return eq "showdict"} {
+ return [punk::lib::showdict $result @@dupinfo/*/* !@@dupinfo]
+ }
return $result
}
diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm
index af1c6e09..c48ce5ee 100644
--- a/src/modules/punk/ansi-999999.0a1.0.tm
+++ b/src/modules/punk/ansi-999999.0a1.0.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/modules/punk/cap/handlers/templates-999999.0a1.0.tm b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm
index 9707d631..40c5a99e 100644
--- a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm
+++ b/src/modules/punk/cap/handlers/templates-999999.0a1.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/modules/punk/config-0.1.tm b/src/modules/punk/config-0.1.tm
index ac70e97b..5532cb80 100644
--- a/src/modules/punk/config-0.1.tm
+++ b/src/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_<chan>
- #The counterpart: default_color_<chan>_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_<chan>
+ #The counterpart: default_color_<chan>_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/modules/punk/mix/base-0.1.tm b/src/modules/punk/mix/base-0.1.tm
index 69f2f5cb..a4bc3c70 100644
--- a/src/modules/punk/mix/base-0.1.tm
+++ b/src/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/modules/punk/mix/cli-999999.0a1.0.tm b/src/modules/punk/mix/cli-999999.0a1.0.tm
index 137f509a..4adcd5e2 100644
--- a/src/modules/punk/mix/cli-999999.0a1.0.tm
+++ b/src/modules/punk/mix/cli-999999.0a1.0.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/modules/punk/mix/commandset/buildsuite-999999.0a1.0.tm b/src/modules/punk/mix/commandset/buildsuite-999999.0a1.0.tm
index fbe03676..44d4e00f 100644
--- a/src/modules/punk/mix/commandset/buildsuite-999999.0a1.0.tm
+++ b/src/modules/punk/mix/commandset/buildsuite-999999.0a1.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/modules/punk/mix/commandset/debug-999999.0a1.0.tm b/src/modules/punk/mix/commandset/debug-999999.0a1.0.tm
index dc9d93a6..f496df93 100644
--- a/src/modules/punk/mix/commandset/debug-999999.0a1.0.tm
+++ b/src/modules/punk/mix/commandset/debug-999999.0a1.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 999999.0a1.0
+ set version 999999.0a1.0
}]
return
diff --git a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm
index 97e870be..890ed8e1 100644
--- a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm
+++ b/src/modules/punk/mix/commandset/module-999999.0a1.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/modules/punk/mix/commandset/project-999999.0a1.0.tm b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm
index 33a3b44e..cae34e31 100644
--- a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm
+++ b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm
@@ -20,7 +20,7 @@
#[manpage_begin punkshell_module_punk::mix::commandset::project 0 999999.0a1.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 <ensemblecommand> projects.<procname>
#[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 <ensemblecommand> 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 999999.0a1.0
+ set version 999999.0a1.0
}]
return
diff --git a/src/modules/punk/mix/commandset/repo-999999.0a1.0.tm b/src/modules/punk/mix/commandset/repo-999999.0a1.0.tm
index 8f2272bf..5a307929 100644
--- a/src/modules/punk/mix/commandset/repo-999999.0a1.0.tm
+++ b/src/modules/punk/mix/commandset/repo-999999.0a1.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 999999.0a1.0
+ set version 999999.0a1.0
}]
return
diff --git a/src/modules/punk/mix/templates/layouts/project/src/make.tcl b/src/modules/punk/mix/templates/layouts/project/src/make.tcl
index 54bcea69..75624bc3 100644
--- a/src/modules/punk/mix/templates/layouts/project/src/make.tcl
+++ b/src/modules/punk/mix/templates/layouts/project/src/make.tcl
@@ -314,7 +314,7 @@ if {$::punkmake::command eq "vendor"} {
}
# -- --- --- --- --- ---
} else {
- puts -nonewline stderr "."
+ puts -nonewline stderr "v"
$installation_event targetset_end SKIPPED
}
$installation_event end
@@ -383,7 +383,7 @@ if {$::punkmake::command eq "bootsupport"} {
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]
@@ -409,7 +409,7 @@ if {$::punkmake::command eq "bootsupport"} {
}
# -- --- --- --- --- ---
} else {
- puts -nonewline stderr "."
+ puts -nonewline stderr "b"
$boot_event targetset_end SKIPPED
}
$boot_event end
@@ -589,7 +589,7 @@ foreach layoutbase $layout_bases {
}
# -- --- --- --- --- ---
} else {
- puts stderr "."
+ puts stderr "skipping unchanged layout $layoutname"
$tpl_event targetset_end SKIPPED
}
}
@@ -658,7 +658,7 @@ if {[punk::repo::is_fossil_root $projectroot]} {
}
# -- --- --- --- --- ---
} else {
- puts stderr "."
+ puts stderr "skipping unchanged .fossil-custom/mainmenu"
$event targetset_end SKIPPED
}
$event end
@@ -803,7 +803,7 @@ foreach runtimefile $runtimes {
}
# -- --- --- --- --- ---
} else {
- puts stderr "."
+ puts stderr "skipping unchanged runtime $runtimefile"
$event targetset_end SKIPPED
}
$event end
@@ -1064,8 +1064,7 @@ foreach vfs $vfs_folders {
} else {
set skipped_vfs_build 1
- puts stderr "."
- puts stdout "Skipping build for vfs $vfs with runtime $rtname - no change detected"
+ puts stderr "Skipping build for vfs $vfs with runtime $rtname - no change detected"
$vfs_event targetset_end SKIPPED
}
$vfs_event destroy
diff --git a/src/modules/punk/mod-0.1.tm b/src/modules/punk/mod-0.1.tm
index 58906c88..26ed2f2e 100644
--- a/src/modules/punk/mod-0.1.tm
+++ b/src/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/modules/punk/netbox-999999.0a1.0.tm b/src/modules/punk/netbox-999999.0a1.0.tm
index 84449643..e55cabe1 100644
--- a/src/modules/punk/netbox-999999.0a1.0.tm
+++ b/src/modules/punk/netbox-999999.0a1.0.tm
@@ -372,7 +372,7 @@ tcl::namespace::eval punk::netbox {
if {"tokentail" in $fields} {
#computed column
if {[dict exists $contextinfo token]} {
- set tokentail [string range [dict get $contextinfo token] end-5 end]
+ set tokentail [string range [dict get $contextinfo token value] end-5 end]
}
}
set rowdata [list $k]
@@ -405,7 +405,7 @@ tcl::namespace::eval punk::netbox {
if {"tokentail" in $fields} {
#computed column
if {[dict exists $contextinfo token]} {
- set tokentail [string range [dict get $contextinfo token] end-5 end]
+ set tokentail [string range [dict get $contextinfo token value] end-5 end]
}
}
dict set result $k {} ;#ensure record is output even if empty fieldlist
@@ -1144,12 +1144,12 @@ tcl::namespace::eval punk::netbox {
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
- # get_topic_ functions add more to auto-include in about topics
+ # get_topic_ functions add more to auto-include in about topicg
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr [string trim {
package punk::netbox
- description to come..
+ A library for calling netbox REST functions
} \n]
}
proc get_topic_License {} {
@@ -1169,11 +1169,10 @@ tcl::namespace::eval punk::netbox {
}
return $contributors
}
- proc get_topic_custom-topic {} {
+ proc get_topic_features {} {
punk::args::lib::tstr -return string {
- A custom
- topic
- etc
+ netbox /status/ endpoint
+ beginnings of /ipam/ endpoints
}
}
# -------------------------------------------------------------
diff --git a/src/modules/punk/path-999999.0a1.0.tm b/src/modules/punk/path-999999.0a1.0.tm
index dd6bd041..9c269ea0 100644
--- a/src/modules/punk/path-999999.0a1.0.tm
+++ b/src/modules/punk/path-999999.0a1.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/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm
index 3da2b3c0..21bf3ab7 100644
--- a/src/modules/punk/repl-999999.0a1.0.tm
+++ b/src/modules/punk/repl-999999.0a1.0.tm
@@ -3091,13 +3091,12 @@ namespace eval repl {
set v [lindex $versions end]
set path [lindex [package ifneeded $pkg $v] end]
if {[file extension $path] in {.tcl .tm}} {
- if {[file exists $path]} {
- set data [readFile $path]
+ if {![catch {readFile $path} data]} {
code eval [list info script $path]
code eval $data
code eval [list info script $prior_infoscript]
} else {
- error "safe - failed to find $path"
+ error "safe - failed to read $path"
}
} else {
error "safe - refusing to attempt load of $pkg from $path - (allowed extensions .tcl .tm)"
diff --git a/src/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm
index 3fcb38f6..27243335 100644
--- a/src/modules/punk/repo-999999.0a1.0.tm
+++ b/src/modules/punk/repo-999999.0a1.0.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 999999.0a1.0
+ set version 999999.0a1.0
}]
return
diff --git a/src/modules/punkapp-0.1.tm b/src/modules/punkapp-0.1.tm
index ce46856b..70fa90fc 100644
--- a/src/modules/punkapp-0.1.tm
+++ b/src/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/modules/punkcheck-0.1.0.tm b/src/modules/punkcheck-0.1.0.tm
index fbf9a4e4..a4113c45 100644
--- a/src/modules/punkcheck-0.1.0.tm
+++ b/src/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 <PATHNOTFOUND> 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/vendormodules/commandstack-0.3.tm b/src/vendormodules/commandstack-0.3.tm
index a45eaeaf..7884214c 100644
--- a/src/vendormodules/commandstack-0.3.tm
+++ b/src/vendormodules/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 <cmd> <renamer>' for delegating to command as it was prior to rename
-#changes:
-#2024
-# - mungecommand to support namespaced commands
-# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_<mungedcommand>
-#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.
- #<renamer> 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 <string>? 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 <mungedrenamer>::<mungedcommand> 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_<mungedcommand>
- #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% <procargs> <procbody> )
- set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc.
- set COMMANDSTACKNEXT [%next_getter%]
- #<commandstack_separator>#
- }]
- 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 {<command> <renamer>}"
- }
- 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 "#<commandstack_separator>#"
- 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 <cmd> <renamer>' for delegating to command as it was prior to rename
+#changes:
+#2024
+# - mungecommand to support namespaced commands
+# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_<mungedcommand>
+#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.
+ #<renamer> 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 <string>? 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 <mungedrenamer>::<mungedcommand> 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_<mungedcommand>
+ #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% <procargs> <procbody> )
+ set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc.
+ set COMMANDSTACKNEXT [%next_getter%]
+ #<commandstack_separator>#
+ }]
+ 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 {<command> <renamer>}"
+ }
+ 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 "#<commandstack_separator>#"
+ 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/vendormodules/fauxlink-0.1.1.tm b/src/vendormodules/fauxlink-0.1.1.tm
index 5d63ffef..970e47da 100644
--- a/src/vendormodules/fauxlink-0.1.1.tm
+++ b/src/vendormodules/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 <nominalname>#<encodedtarget>.fxlnk
+#[para] format of name <nominalname>#<encodedtarget>.fauxlink
#[para] where <nominalname> can be empty - then the effective nominal name is the tail of the <encodedtarget>
+#[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 <nominalname> 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/vendormodules/include_modules.config b/src/vendormodules/include_modules.config
index b7320eb0..895bda28 100644
--- a/src/vendormodules/include_modules.config
+++ b/src/vendormodules/include_modules.config
@@ -11,6 +11,7 @@ set local_modules [list\
c:/repo/jn/tclmodules/tablelist/modules tablelist\
c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\
c:/repo/jn/tclmodules/tomlish/modules tomlish\
+ c:/repo/jn/tclmodules/tomlish/modules test::tomlish\
]
set fossil_modules [dict create\
diff --git a/src/vendormodules/metaface-1.2.5.tm b/src/vendormodules/metaface-1.2.5.tm
index 4c88cb16..ebcf579e 100644
--- a/src/vendormodules/metaface-1.2.5.tm
+++ b/src/vendormodules/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 '<previous cmd> .. As varname' instead of editing start and end of commandline to make it 'set varname [<previous cmd>]'
-# 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 '<previous cmd> .. As varname' instead of editing start and end of commandline to make it 'set varname [<previous cmd>]'
+# 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/vendormodules/packageTest-0.1.1.tm b/src/vendormodules/packageTest-0.1.1.tm
new file mode 100644
index 0000000000000000000000000000000000000000..2d6b86fc612705170ef7d802784f012b0790504e
GIT binary patch
literal 11471
zcmcgxc|26#`?r*>l%x{TwPeduNwOrAr6@}z%cL=LF&Q(=Vo8>w>{=v+5VEz{wWugG
zD3Udyd|DBOY>E8Nok2u>m)H08oBkMc?>WzTKl}SUaY3^_V#jbUkUb6$L+&_=BV>lb
zLwF(@3zHxh66^vKurO90GKF2KI1)^TV6X<fvZLbg6dVBpd+o`x5RnAA*^^aO5m6K(
z<V>UzD3H4&A{0Dw0TQ@ood}6(;VCeQfTrNwV7w<pB_R9AM2O;ura-U<g@ndXU@Ro&
zOvJhnv2reGj1$@cmUDwiWE_zI*%R>yJRBJU2*_w>c=`#N49QcR>B{_epaV>RNoYhU
zm5d`er~-(HXjN4_&Q4X;8SMny0t~i{r;r@c-kuCoD4s4bgeGAe0Zd38yhp600jX1*
z>3_^o31<&^S!2)?j3eYlHzt8daz^8E$6&}BN3bVCWDE)CLP2>WCnF2MUtV)0AO?a-
zBw$L>DHwFCP^fl{$MTRl0c{5?3Ji>ef&H9u1Q?M<1<zd26i0bT%7sWK<B&CEv^@;0
z16H{}z-<%~4nqN^Bkz<JopY%7oL`6%;#2q_*cB2Lg^nMGM6Brw!5%m=g$zx<|KH;m
zh30^n3k|pf(G`m$K@2$HF9PEF89Z|~Pc64a6R@@*Y^L^*h(ro~6GH?Ajl=)ikD4O@
zj|P@>AVAh+7d(zaUo|644mD+Vx`3&uoU@xA4Zm9rAXb<TX$1AOyag>uCQ?ZlhIW72
zr!ZRxi2FGRydfA*h8GAiv3aqBScD963`7kPa)%)dngH}eG8paRLL$15a3FE;o^!+_
z!3y4C7%@hMF%-y43({UFrjey|d*Jaf!2whlaV-?IV+XVeEGEGeDv1DjdCzq=vIY6f
z-KPCtZ_|LRXC3}0kjRNh+#qF6Tx*`X$ZO<-EYX6*wg0+68xjX%7F@Ehs?!I1E&SS^
zNP^Lzws-(!kQcI8O58*GkA|DITzi2SU??(WUwU<#N^V5xg5fy51Np{-umEj=VJD9T
zbwrjetjNMor{Z8io6X;WsE@~>$*?V>65Ent2WOZ7ijy@`=?D&>MB<6=Gim=Tg+VHz
zQ1cM~lE<i~NHHZND$JKh!QfR@Db7gWAX63)HEno2#?~1T1Bo+$&K5ks>?21ZAn03W
zX+y6dQ|PB9&WDfeo|7q{;ef(VPs*v|f47tP+>=oB%=(ohzrFoe34@fuS*Y<OG{FJ1
zz1ip)r5iOX4}UuY0uhCR)WoQuXdy)hCIMoA_!tWz;^+AcQ5yN!fxK{9@a_D#ng3*t
z*~I7Q@y9ek9A!_%<EK~&WPOwfXoxk2NC530nk$6fH$Z<zB%>fzRYXH%FGTM`M0?P;
z>C^@S%mrwUMF`FGBNBshEvOqkSdbEJ3yz%XDGCgO)6sazc+UlbLOKsv4`bzkD-cpO
zyLrqz<B#0~G5PNXKqO7+I8V^@divqB!Tx7(xaJ9_dyZbZFhpl((B{byJvR}S28byA
zJQM^7lBnpP!dDDUa-br01JGB5PhuRAxCQY>gzP{U1Z)Z9IP#j#i>LXms_H&^Z-gnB
zd7uz&#b7iNx>KxxtjeIs)4S-nTtL83kmpDgEGz_&RM3yNY}%qIw@F16nk!^#C!<Nz
zg)J-uOC(5Akhp>*XK@ipK+ItRL;<W2DV4tvkpY1u69J`~#twnt!oz4X1#&<buror5
zz&94gqdmzGAmZ*g0+#4bhFtJy3aEU5c?0%JAQI&0?F0=}kX{&>nIl5p!A8&|sm_4a
zdV+2OgfOhHpa2|zU}F$i&>X;XkRfQ`Pl`K{<V2^tbJ-$ddgL>c8FagVj(`Qs7jl9D
zVC(q-^5<eIs-VCKC4^-$5=|5$;E;p{zZk;*6j%rjK(oj$I0_7D8Sj~jtXTm%ljKvT
zhTM??0Imrn3Kd+7kV_GP2wdlarQ1YqikUGS>O>&AgKNp0*hNB=NTom&k|*78l!dK>
zAfso_)J<hU?;wkikJvnW&5&hi#yWq?V^Hjn%N*>C=tBk_89AFW<$5&aP9g#yJ5XUV
z8InSiC^&m??Snv3L?c}kNlb8K0iK@~yC7!BR2bU1a9A;51K=)Hzy(DA0{@p!|7wAM
zN5Y>C4T>m<wC|67WCktp83b;$fNkUciUx6<$n+g^KC~H^%qTbGF7JN{0s%v}8kqu0
z;jb$w8C*X#G&E*~?o@4s)DgFU%kZy!(17egn*(=!8-g7O#VM6k7uq{})07}G6@!6c
zFl?{^wFzNavn%<pc>9%((2RO>ue8&4o&7yWwOvSMM+!dG#esyz()l77dXPX~<3RNT
z<sXC{qv+e?JU{@_ksyiu_k-rsi)jdde#7wT><FLl#sx2pzhD0TrHAL3fWZNvY46hA
zfmHkd^6)9g1J5x`MVAL!pY^PtsJ|O;PO+g97>E|Y^VbZS8lU`{lh}g>MGuqdyEZZ&
z0vrpZ2z>}cZ&(ca0*TKeb$`aXuq(Y6t^#797BNgchi*Y+svWqAfJ-wGq&^z&j<i#x
z6(VE<paT=OnXwbNl7sOBawTVQ5;vHD1Is``{WT{8><5Wn##Z1(q!lk{r>UXBf9d6U
zBLB(~#q7~|yd9voNJ1gSA0*r~hngn|NffdD+VYSEpci!3f&si9bWg+-bQa(YW05fg
z1nfqJ<iPw9^g8g45hsAj08WiC1M<R-n4e}y1R#TznPU0Z1VZ*tSKi<F`HWKkX1S*m
z6tV*(`YTG2aqEnj8EOE`#?Wp$KEd~N7=wNZe9p)&geaihK;@+m2O0C(-==)ib!hr~
z>H_Z!V1S$z-D3}k6=SZ;5IK9Cizb0!oDnZKWp(<{5s6BM=|ODLXU15_&J*xN0u}gv
zYOd=-udl#W^ddKtc*sQu4`xpCe@-<7?QclUfE@a?7>tx5z>NTjKs*mln@SIG(LyK#
zkdB@n3L_-@*DM(UFk{83T%(VWU4Wt>{ibHifR0T={X0NL$q@&pTrj8+9sZgo$O7a;
zzf@r%>**AkzA#Lqpu?FPuzx%dk@s&z{Qst}Acy?|Z9Y}G#qAk&cMjse0!HNgKh$sJ
zn1yTjpWiIJ{<jG&a1`U3@Nb!Qo+;*@G4~hpKQuD|4+0bv(_f=S0b>K!MSM(5OdL!d
zLMN?Yuhh=nyi81w_b@TZgQwH|XR2zMfm@&4Ci%_sn-%6g0ll$cofEnBNxzzJ`QjAX
zO}z2NdN(TxYSOFynYbQ%*=rM;=&g`Tit&l<Z0!0;Dx+W9+lyG28J!PF-XqI(r?tIx
z<V(Bjv$mDduvS>H9%lH_ne$<iKD;h&=PG2Y{bhM8!^+!=Kgkw-=pha&dLKU?r?JI0
zSAWY+PD^<euZNa;XYjpm`ac<_7^Xgw{<&Fa^zxDK5`&607c&m!5tZGqD}NC^^R_QO
zjn~C6kA~mMCg8(n!z9ZS9Ht%5@?OevbHc>C0U_-P7uRxZVYo_YvY+H85~q=cH2cdf
z{<zQK2|A%t5xH_+LAlmRV_f<jC(c@5?jPdIzQ0POIZ;{Kc3|rVk?=a>4NJxY<hH+a
z%@0|fqrGy2R-9NtAEzGe#oG-<_xx?k7M0~!MyeI|`vW6cRw--iUe>=I^sRi!=-0$a
zbl>{dKhHhz85%Pxi~L&bu-=1Bz2myniQ?zVf{FEdE&MhXcg8I0^SahntzakG?PN`A
zUh1pK_VMmNf)mGMB}t|Jj%)k-!cTR1^G4{>>ehuoD@8B%T>Jsu6H7~oi_6Yh8uY^B
z;cz6kY>)kk(86fXywzyoZ?Uhc8ei?Wv?i!}Tlm4-YsqI%EYo<JB>Pb$nz_|Gv9f3U
zQ|M#NQr)a(^~#qu)D}J8>dWs_zU@ua*n3#kMDUUPmP#I70cXd6&#O5E(@oBz7CBBd
z94XF|7+d>}NvPv3OR#l%5XTwjk_(eDdeXO}!#uu>4r`@c#UA}WT9L#y**2Q-b@Pb+
z-2xTjp*~`E^^c&PX4$8Fk{lH(OI5x<HuTz9;)~y6Db}SA^D7ST$zfKJ^8FSf)2;oG
z`Qtb7pgTHO4~Om6Tb)~8m~(GCOTmE<{uAuM8sBOK!(|jLSawbJH+R{#H7%iV<*mIF
z9Ivb~dhek{*WSWr|J@#VLTb-ad((=KPkDcoSf?E6R5E7H(pvgX;&R9HH3|JX{<=-4
zb#`$Yl6REZ@`R3*Q`Ypfs=YeFxjA-mj=~0ml2!Up+<MNWINIog^{rM|=qr=xc>c>%
z&+$9jy=Aout|q28EWP%Si&7D7!ut=Ndy`deyZYXXEbl}|54Z?_3waC$rblC6<4>FH
zL_N+E?8;K!yz?9XWR%K&bb4>{p%+Ii*^LI2j6_!ZOVOJ6LkpP8k2XEFEL93Kd8dOF
z_WDu({lkXs)-10N@9~P!xmBLS_Fy#cW6MoHDL-a=b_th*`M5TtG;M)V*BfOGj|d^F
zS8v-Sph@Go_K8}0fFxPhP<9I)yH5L}zrQ{HWNqBX^rQ#f-Zl!(1;QPhk}P}h21)5R
zQzASL6<Ag9ZQJ0Q>?$K##I~eFA!29)O(oR#NX*#ooy=V?@ds<JRL9h?3@%-R_Kc*3
z>;Kc==DyQQvRt`r7f1d`$%?AlA*P1hL+X87nYuZijJ`G!tHKE1P7pLsR@xU+oe42b
zZkuFlqHuI+1}+}RUNwAEUwXvusXFI{q$76D3f^1s*TnW!ORQqvh@yQAGYP8;6C7EA
zU;A#I{*i0NV*afi>^aODzLI8{Y^2KX6xE4aed>ZNH=opWK_Ye8nP}<f16$D%cgPK;
z+Aj{5H?)K`JyB{I{pQVAM_l9M58<27H1hS`5)in7yAjF@qjp{Pdit(<sA9i?P#O!*
zfh76MMQq!Axr@j3hN<5LgxL9xUeWYv(z;@t%u%@tCtzQY6V~4q@|qQ8y`v0gclX7q
zBa(%ao$g0IFG=T&9ZlsvzMka4ULI>ya8sC)IbfgKzctmd!uZ8U&fG<m(*q@+B)smX
z)ouCkd}Gznb-@@{|3&6;izm)~umybmT$=G^w%gCD3k7RdCq}N@Yq*B5<oUa>D^&S$
zyUIkaPtV|^TP|M8VVWq9lD^0*7N(+fa4~#)dBNL@SA6f^FOj)?{W05hl*fqT?wXOW
zhjZ80DEJ(kTqaW*@Kiz}i*U8fS6?JLGGNEhdcORp>vw8dtuPf|Gg!sbpUbSB*&M=Y
ze8Io}giGR=i=EGt;qOoM+#?>!;5Ge1I7P58tf(URf9mrO`H2SR7Zw!5!4(2LOf9<N
z`A35c62Fvahr2z>851=cc3Q?)-kLfl6SKcmzb-KPUQh`x@q&JB4Et>#-b$raJO`eZ
zRrotD@wz74)2Oc_RVPBhJh5^wTrO7AzjVTiV^97EMNMvz!6TZ{4R1S#_zrWQ-TcWa
zTtHXr$-zE1ZI7^BwU}0>uqa`Ul0#G><5rh3<^oz1x+S$yk52$o&GEp56JxmN{4?!y
z4$pE}Uj%;hMI9es5%#{fxW@PR^INZN51Vwdz;XPCtz<9n!~Z;+qQ5&z-dL4Dqj0$9
z27G8asgS1(g{9%bv#W{(Wn?aGK>IAkx!q~hmk|gVIFM|1xw`5uUt=Dd5-hN}V~Fj&
zT8rY%Ma6z)8^Y?oL~mi=x%=tGcGfy|lXFEsUmG3h<I=ZM^6L#*{g3XkLaB{S<{`>8
zyQNB`F|G9{gIqaFu$}z*w$X-adi)1fE57PdSDmITO6B+6_FN?V&Zo@*0Ya;YGEcK>
zo3|!w2=Y#hv8J8oO1WQeCvUG<?WBK7v_t54lH+TpTL0ndSmlZIn0+ilH(q}3N=Wl1
zU#}(7Hho{F%l1;Xad6zo?`hnKX|J@i@h#n^D=a|-5pl_F+SS%?Id|uV9aJ%X-z_ra
z$?025mQdnRTFGX8p$@&LfxjXD4ZpTRlk_U%xR>bQMHFt&!AQTiWx|QywtuXYDS{(O
zcWAG(yIr}>pE7f2hnx7+xJjN`{3<Ew%a^YQkF1OG&j_tDYW}HP>cvJ(Fc;2wZn2NA
zOtpadlwbS9?vFa(v|OPJ=LIEomKRAL48RQxoL%+Ob(qb&yjt6DiG|R*p`7bp2hIey
z`$<_C`!&!?na_z<%Ic&QhM8U%TXF*<`CitH%TnsH`R?SH2QsQn4wf-7RdJs`)AGuP
zhK9y_#>Qf^Y;A3`IDZy|C$7tLQ`L%4GQ3i$+Dzsd)GoWweb~!4a6PLr_X+0ac*Wg^
zIWu*I$Me4U6$Ywv52Q+4RyS2KsajeOR5|6`U1=Ry7KDwpTRi-cBSYwRgm6H2UUTsM
zl}<0d^YN_~89ADRdhhluFU-?%>xYlkIgzJLs5eqpzC5dkgLm~ttwGfkv}U}lyW}`>
zPcYnSW6}5r7LrwAtK6ggiNn;mB!gl9%a&26K67v3*(vUE2LCXm{N&x>l3bNxu^W`9
zhW?^I%CPHI!;JXW#>=1GHQKAUS*`z`cWk^8?Mk@(ZP;|H=SJa6htX_{v&U~K@zrhn
z;@?c0;HtnqGrd=Rq^(fip*uVHRnMr~OCQ6*Z3a*Fv>yt2;bTxcaV_}dw(j*d!GbB_
zF}X$!i*giskHZ%ar}Fsp49VTq?O<MFTCgkRsJOE0g%y;KajH8^GM-@^&(lgi#Bnbc
zYU@5D{Nve!2AQbEtldA+ZASjq9D}z}C0uMRJa3F>>iZ`a<zjU-yiTE<N1mzqZO6dJ
zBzoh7G(Yba(J<zH@;E=?l9}JV^355Yp?hzx;|<LGsJeDXg?9SR#9C6m$$=L-XXC}v
zKfN435oqiny7t(Lqc`%JE4Oj=ozQT0FTTk8vZW_2^y&5C3ag?fftJSa8`b=xJB!nc
z*y0c5E<U4^tIhgs_oqecx_3o+W))$}{BT|$hL*uC84VKFg&P`Ia46qdWx~|y&eyK^
z^HRq0!HYjvg-&V>H8rK=6oq-LvlCiZDBaYX(?kvvE|YNQHrs8?gYj?RDNvIh_EdZ8
zbUk4>;9<;$v@e<|D%)y3OvUawywiq_TKC>w#;u?}T+M&i=SHiBlwa~KDelj~Z4x#K
zGNG#G!#Dkh&R;Ry)7p^LU&*&<h+}{EEw9F);PY#u<cF7Q6Z718-gXILPyR542}i?=
ze%`;#%U4T`Pv2i_+IuQ`3F-7(ug@+4@mnt$D`d#V#^&T%R$U8v<ikADw|mu+ptoj0
zh7*?3=U5Cg6_*B`^gkKNQL*M-r{dSWjr;fMJHD;ZwDr`zie4^bBl4`fW+*W3XJ1m6
zQPr9gICj~>z>@+|J8;_WI(7~Ca*3*x9~NlIvrb2q4Ueq8`BczUUhTw<rTY8SJ<e}Q
z=lrSa5s{l!nJBu3eIQe;k;x*o)lNRv(c)D#i@C)x?-5e<c||>rtT2btOm?^67ioG5
z0yU}UYqNJNB`Eb&o<~XQZD~3DfQ4LE_w?+sY@=QFa&{}0swt_uR>rNbXpd3Hr{-xp
zxOA)T6;9&W!Ry<W5_R(uHbK)%;qaOXHx1o4DSoosxfXjhH(aEpu6KSVa(36jO+?D_
zoQ(I<0v{iK3OkL?_N<hb`erU46~d1D99Vhx##XM!GU#Tf-tx^?t6B%`4W8_Kmi8iX
z<(A>o{ngrEddS+kExD3XnXukB&V$+}=echw1SDPw>5Xn2e<R&HIrx-Tn(M>A{nDUs
zRU|3F3ujnS)njh@rZmzPI^7+!Z~c$b9a00tpF097WXvykLnPM6r+L~2IwCUU<U=nB
z^LSGOt>eFKx<zwk^F)tFXru{Wh@~VcoEAK@c&h^6a?j4eDB*%Do+J2%2yW94{2Lxf
z4kcmzC^34p*xWGx^D*R&qirn~j}jw}KVo4kDd=5lRI77+w<IM-#O%1o2R8M_O=IR&
ztjk1~t96|?p*-Brw9&wfYW!JNGmlB@VOwWNMa<1}u`5!SnFiJd=aIH{D|ij}sINbu
zHH24iKWLf!MIyL*L!a#atlQ2{P|-V2KB79OC<=DE-n<}jzLNQwjP4Z{{9vAf$g3yo
z-t9Eg($w^-<A3htb2VX`%YB<g+a8Cd8mCt8YS(pbky-Vft^K9I8P9(%%c#=QYGj-r
z-7!AD^~1H6M4FA<DxTcF@h!3{Z#vpj>zS65GM;1qxxif4wqIkdS!$T+r>iCzUzv#5
zW9AA`)&H>O1>{zoOFl7>jMks%y`2_4Zsu?^wf)Db0`)`O?G_#fL__XxGS@3l78a0L
z^u1Dvc4>9k<HwPSuyfXz+>GsdgUTM2k+O>$4>1QeptpbMi1cW^+UDC49FV`1eQa&n
z*MR5~nkN&OJ0D^tLthp*K8Q3Hf3ApHArPY3w$U^5j0P*SWgqR!As(7?qfET$b8op=
zYuk(bgPesweU68(Bc`+4uwGyJGwb8AH4n3{n0n|;)_k&9DfrP?UM<3N*v7PY`^vSo
z_u(bAt!k!Rs^%w|47vwW3=_seH~a{C=KFl7_x;h)cZTlC25hkh3GwD7)uycHXd>N@
zPJZ4MUK3exKmYNlZVMV^Fm{S%<(QW#*QMK8OGsx0yPX4H3Q6n>>&En6-&c`iqMW(p
zbYq%8z?LRR)X>u|fkb#{SKlR_u{fqWgU_R%B|Y9vx3a15u730BY=1T9YefeXcMuf>
z1hU+91!(tVxK2MB^nAO`vA2Ds<oGcs$8kUWF(ygZ=W=_4H1D;xMuZ(XE^2NuTB7A&
zU)pQa=a+A7kpJ|J@`|<8+?BhkYwV#F*4cXsGI#vIDqnCJyyqt9b~$G0y5-WSg2l%@
zSk14zuc<G2<&!V%)#&br+4`zp=D^8TZneg4o`ecTkCT_L(bkP{tJ!wEKuHbv1#O70
zqx#+%?V7mpB(lCTx44UMgVxcstUV8(kP91%1l+7u_u~q;@~pmN@?GoJ@Ys#3Lk}hg
zyWS*Z%W-@*>4=joy|-UqCu^m5`uSlKg%X8h9|S)+ZhW0wuy&;0SY4c5`c~AQ^|$V^
zl^!U#ozfTOo}DZpL>t~%wW05oYfu{P6Z0_Z3znuv+w=ZuT-Rte6XPvA9iD4Ei$}S|
znO^@w?N)pr{%XmJNhaM>T@G2py^@xnr2YJ@(%!r7ad;n=qk)p{6+jJO{jwzmj(caZ
zCk&a8^aFA_>#NeR)NS1=&Wa7&@u=p~)e&FHG6+_^Hk#-++9mD%-B?~FKPdfmL&Wuw
zD-~b6_IB2E+6ejBHZCi6k8e~`kvdX*M*H&?Et*J=l|mZ-9g*!6|N4gtF_d=U24&SV
z4=O!-%xesCcdS3EcHg{Tt-UK{<EU+)U0U^~HrbrX)a0|p|1_n3zsICxgKEEV$*jFS
zrLHOMYo@;Riqa&0&pTgv)9!itTg5vJqU4N<N;%DH>?!B!{l1GTs~E&sxvNwsC*2Pm
zE2kdrs$98hQrYKI$cvCA_wQdB<vBItR4`^LB$h9k8Ou^vyM32V^kejk*QTnY((wa2
zVjd<TIVSa!EfJ1B9Z|iRpO^a7|KvUQ%Am-?>5W>FLJnH2!#`r%gl%Z@L%Da8#s<tR
jd`y3yNP(f$tj~WopE5RB%!X`c2LEip_gOIMVq*F~xlO=r
literal 0
HcmV?d00001
diff --git a/src/vendormodules/pattern-1.2.4.tm b/src/vendormodules/pattern-1.2.4.tm
index 5d76af04..d6a9c932 100644
--- a/src/vendormodules/pattern-1.2.4.tm
+++ b/src/vendormodules/pattern-1.2.4.tm
@@ -1,1285 +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::<id>:: instead of seperate ::p::IFACE::<id>::
-# - 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 <value>?
-#
-#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." (.<iStack>.<iFace>.)
-
-#>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
+#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::<id>:: instead of seperate ::p::IFACE::<id>::
+# - 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 <value>?
+#
+#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." (.<iStack>.<iFace>.)
+
+#>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/vendormodules/patterncmd-1.2.4.tm b/src/vendormodules/patterncmd-1.2.4.tm
index 4107b8af..ca061a7c 100644
--- a/src/vendormodules/patterncmd-1.2.4.tm
+++ b/src/vendormodules/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/vendormodules/patternpredator2-1.2.4.tm b/src/vendormodules/patternpredator2-1.2.4.tm
index 457d5742..680ea88f 100644
--- a/src/vendormodules/patternpredator2-1.2.4.tm
+++ b/src/vendormodules/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/vendormodules/test/tomlish-1.1.1.tm b/src/vendormodules/test/tomlish-1.1.1.tm
index 8405fae74a50ec468daaff5adfc86c3c68353219..bd9499bb1977a3695906bf55498c269ffba1b933 100644
GIT binary patch
delta 8989
zcma)Bby!qe*B^%NPKiN6YG|Z8B&9>T1{hjq0LhV%6hsaw-618ZaHUI7X(U7%1O!A7
z5COjteedi2?mzFD=Q(G^-fOMB&z`l{{+)p>aC8bdNeBfofZg?l`@j$o7#!&W^MTm=
z!rhT@Pe>r#+X=x3@$!NAIU%H^&@2S$1@Z9m^+ZDaUEuDppDny$j{F3WKQ1;!cO=Zm
z(+&yugSiJld_8~mLwG@uE_O%=>>kp`&H)K?gs^#dIeL3JLcK-o9Ng@jVNgGq4+8Gx
z332jrcSHvPM?laaAnZI~|B=`sApA%Vh!fiJV?kzBDRd-1El5eZ!|kP{JnY<HHfUEi
zzoZbTmy;6$hC~K<!ytA(4ld|uATntE&+c*%8KlP*@yy8vx1k@Gk(d?2W#{SmYse5!
zFC@gy&kpWxXOAA_uUX*+#%P(7sVSH}f6vlSTZn&5j-3w-(g2|@!zAy_2sU34BnZjC
z0)Z51Kp<H_5DEcwG9dsRJvT~y-jd58m203P|3|yDK|Qymh6e<@m6gO^eQn|3L+&Q~
zEqblJStSMj_7q`STS}O!U6Fc&5!G{Eg{qA3<)pL=C2Hd4HsLqgp72FClIVdk+diLH
zP6WR1GS#b=%E$(~eC)?3U4%usBKvyc4es0!j=}MzS{9!LYmFnPjj~WOFwIbyNpj&l
zNBWp}!5Fa!u0A^-C1b`$elfLV>qT8}e7`=ijb=o<d$kfPO~ok9NF*h)`1Mlx-Cakg
z(;|eo!jH8Qvuq__+J<LL^LJ$K(n~!uExQ{TAJN5k8S6zevQkdsTdk4Gm*)M>k|_G{
zeX(I{1e>S~t72chcK#tsM=FtFcJwXLFg4w?QlYUb36VQ+LT6-<vMch&rrsDy>05zm
zITaghLsw5krp|nzyQ$!mHnkCpcB<Zk8N)}z-z?V>Rt$xXQ+sR!#0~f<=Mx&8KfTp>
zAAjp%hVIg)KdISr2{&~#_7ev^^_QJ{4V;Gd98|Gj-h3$cp#8id%1Gq1uSZDW7m51d
z-fJ4(RxlP3AxRYsQofVvrD&G!?*onW$5N4!_W>3BQgX2I+UL=^9(N16qNomr1#26t
z&@-mWvF|oD{Q0gxbPf`6@NN6c26&RuOYVK58ZFD^^V4gUaqX`nTB8u<atU(QAI@=}
zPSg;1dU^y(FnJzUp}Y`ExhLN<rYqw}D%@I+=a5ZOy9;?^Cy{vgKde`ZxdlWxD5Hc!
z0tt`=5*r(IKAhxA+7W{YfK3aZct|jDja}@R$vKVsrU0eI#!BkURzj9_eAeKEbQQAx
z=*DiJvDnmEtC{v(U0~UZ+Y&-2(soB{E0RE5R0h1YJoEi~l*NqNVP4m_6P19hDNvs*
z*(#Aj(rwBjLHF)w(T-Ep5h+6ntC(f#Y4NF|uma|=_!pBIfeh?541GA0xcO-T*#^({
zGu+a;XeuM>a)Wxl5~u%=x7?drT>4IfnO$0**edA<ZEk5cNDno5B}#3%Qf%<Z@a6#S
zdPVvWo!sE}eiZ3?*a7M@2Ezayn~J(B>3kTDoEYrIE0x6igR1s43_T~0mbp@BY}3JS
zJ7pix=J!P?y?*Wio%U;>#0bspBf`p~kvMH9;}`$xon)RjAVe{2CVzu`gvugu0CYg8
zM18*wKdGXe?eKQhojB6RDX~=2_!0UlBpC$a!`v%MLMo^&B1$EPMHoQ|d|+ZGZ(lyK
zE-x|&V>Whwo{Lm0H|uS|>$l{KYY+6g?kdSRJkW-?@V)aqpiJgWC#=Y1XchZ%%3YzO
zwHh=(+Ms3nN#je{2WOk>1im-*<R)jLa-^oMtNKZ7UP8_(EOwvI)<r)mQ-%<y1u~BF
zoNxxCmTE3gjV~{ET#>U6-|t0|Fl5*o_0+bAvz5!CuJ=w}1hiX`TwCPaHQB|zxAUI=
zjqidro9c2KY2@Au@oVLS^kDaa+z|^Pi~J&HIS-QrHk4UMs`T+bZyDbA3X{bMVH96l
z@amv=BKl^!JjjwuU!>?<K!U>Gz*FVzUJNfnVdybvVPa8%Kp;F2UPq{Tx|SjPI0guW
zO#lK3{7h3QN0^_$U0*MBl6Hdy@FQUe<c}YiAP@$4H%;GdUXW~H5%U{K^s9+{QmaLx
z5UrW+xs>WCp;ij2@7Xa!$!x<O;iLYG6=`noG{or|b;shN3k&<VZ(Jy@>c1MtZB`q7
zUj0H%utLx*^T0(WxvDen6W-|{R_`-$Q9?f%FhdRsS3t8Q;RL?2dTO}(Wl+?aSMi}$
zY(>{6#zGfcO=EqoS*45eQ9V^-=<E2FLk_VHISh9<)y8$qy^$^kV?1k*{6Z<bjEXtL
zHChNQZin<K{n!o#C+qI4ChU9Ymu8Tqe^YZrD#y^LS;rzPB>l6PnfmG~mJicN+Rzn=
zca>(SGkR@2?;lbsSjd@Ub`>VJ+K;aT&5FRHRYaXKxI2d!o^~tB3*HR^Or}k*A8xGI
z?}oG}y^Dx-9VN!);yGur>_24uim|^Br3aHri&*+!IOt*vYv6h<)<ui@PbyDz2<*BL
zy?XO?>in2@W=kjeb?Ks0N9Wv@|BnSp+;m$n6u@%WM{7H|+4pI4Dp&~fv9v!5OY)P~
z2uHR(m(;;{kRe8%G&ZAU$h{ROOiRtl&s9_Y<KR!at`Zf?5mVkOgtR{<!9v3P?>fsf
z)kOHu*Wf+G?L~67Ew~cgYsE>V#xX$`iNkvNU6)#K=YN3o{$35xgb;H-y%T~ycl54R
zPXq#qp_hXQApZm#^?L!7m}+^g-XxPV?Xa&L^sX<bU@udOmgS%80jsvjQYA8sQmmI3
zs6#bilvro`Ijj}wuomuZWj=&c`?n45jTJ(1non#Eqrx7p0idT07{<`&VdmWlCOLf7
zHS@Tre#h7|%kT~E^anhzqUgO!Uu;GCMx8&PHu)<V#ZNcw&6Nq0SE1$NRoSdEH`+X#
z#lXW@WOf_Y87A1vR=?Dlq>#1VOAW!&e=(u7iiuMD;ft+v(X9o67AqyaJ^c6>&qkH}
zy4*9&TRt{z=7_on3i3DO*m(j_=b89}!cxb$UgS&82IW~Ma4nt>62o#53C^W%&9pI}
z$G>!cL4BcFxyQ|IG{Hqrw&n1gIF<n!bkedbi0DtVbc@jm<8Fafi_GXV-hZTm>(^98
zb?<KOfZMRF$ou)nY%ElleP1RwgoeW<aJ@98B7ckuYu9g;V;R1A^i=){nWan2f?~OB
zv4LHFwXNBGssmQZ&2OBU=Ot-VU^z?RHnZdrAuej<$mSDO6z#pfWz#fjP0iPG?1%#)
z9d{tPqtjE+r_tF`CLV(=dj5Py=T4S`?ik!gj)VWXuYI;wpysYy{M=N={Q#(O^zP%*
zty`xmVhWex!<b*RId4f?3Y7Uu_cc7wgwyTda-1{-ijY7{XgVBNdPLp@!RiiADub~<
zu{WYTGlgE#ve7yBu^H9iJ2N^Zgs3ouj#Vx>y)Y7fxTshR|0@H}e)Zb>rZ$tIA4l5-
zl9u(@^_8SPCK{gd1#d<~=?uZ1$zg6><<Fk4y99D_y=V1`l}=~0|4Mbz;LYEDcqc}B
z3ul(+A&7Umd!~lbV`1+grMYX%FYcg_h2_-_s>YUP;@d{JFVP1PL1k^E!s8>O@{w=Z
zVj<xD#akcVcHQ}qu6|y1@{~I=R9`T9V&;ja37)Zx{v%PU!Op#LjamqC_`Snht?+T3
zZ?Hqd=5N^^q4Ar(zPpsD;1lOGi(r5Fu~g|g-GqRilhsK=<LZyqz{Zj)yGIENZmqJ+
zf1xf~8D)YM)lbAox&?8GNgRw<-G~;+MSMa+<$2+8`1|JS=WULxcUN0QJ`xO6*+HRF
z?4WD79p3~zQdyeD^k4%bORBuY+tnog)-E3(1gmsil$bMLN8XdNftx(HdU`er*Sw8C
z@wKqQ_-s|fmXGI?w@9kvGqv7!Q4)7nd_xo^)S;l_T<&1($aw`%vUf^^y<xmE;Ijb9
zT5?|F+$y%ClfAJZ-i@*ZA}=qybXY<ClNLq?o#o@bs>=oQA0xn-=dS+tsi}I*LdCs-
zr$hI!>G+`&_#etM1P_L2MEHp0F}I^Vwj=GNGHDlwBkczSWQqpbPOSucLa1)Vc5<TV
z2tKoTUqaOwN8)x26>Dx|xjlO|yzH0G*rPVqmQ2M7cmL2-RJTMp6>H!L#d|=x^kiuL
z@e?02VOH69>T&cO4UvH;dhHJ8?N0y6K~^Z1Ge!F7eDT8SCH}LsYD5P}Y7fw0m=5)3
zOxm&`r~G;t6z~eWB{)>%(Iw8${M4|?<93srP9($}y={TOKX2&E{;H_<eue|QcA~h+
z#?Q~|Xos{zAbortkiI^!e{xs*7{8O9?>%?8r`zv*h6w^BJQx8XC=2k@%;#DH+}|1?
z*25V?_-_ZFYq7~~9DLlJ_>o>7?*C~c;Au{2Tp0R~piDqGfPMoDuzwF5==3Ck{tU|p
zePVJ%`oO*aOa1?F&||_tM<eCW2q>}sjE1El%l|qCxntr#$7~HKvO=zct*gh?w?SO(
z(^tlRI{FzL9O3ex=b!4ohmQG2##d?zHFtgI(jJHl0vX-{frNkq4_3gtffAkY(IvsI
z<-8|4-G`)g*yr<&5<XFFQ5fr1V2<+~#aUoio$f1)!3;}t$%@gIWN(Uf`?x6mmwMV-
z+p0uX!ny6OHE(s|5mwRxpG2xuO{MNt{3A*XS9L{>mXwAcG4}Yl6@&NNvDFF$lF6qN
z?1M$}v`LodgG!?`Diyxl1*1Tbx{&K}>Kx;GCE-fhNqBDUZcXM66dwwu$&UD8W+mNb
zEpAN`^!l+)R3Duwl-oR_U<9Sm&UdfxC-lea&Gp{&Z0QiE$&0lurY(w&79yrj_z<>l
z>elTj+HFzK{8h`~fx}~XmCt+?Os>%Z@u=$}iTmB5Xa_vjLBYR-ryIq#bR_4LJw(*1
ziaRi)EEOeQv$<+bp`&@R>5w1c?+u+`_LJKE!jBtlc!s%HpCx%1%=m8ak)Oqgj_t+<
z@mXba%&U9acZ2uT7N4tCOSZ^n=OpW<N<6A5-u~*6ecco36(861R8w-N$LJd7%Z8@e
zaKRY%^~V(MjB9`}uVODM$?PokCjF?{IFw1XYO$<v4-V_y-rG>#93u4Rz={;&U=$Lx
zGTUi=-Vb_8;dwNi=F2}KpB-{eSxQ@$CzoxNt@M7xl{QbVo2p*5<U_YXIqjm6bPaBZ
zNsys)G^`t%<1#({%`TpHlr=iA#B|{CofOTYxk&M~-u-X2k$gcYj@PuxPh^wVFJNVe
zv&-5El%3SnJ{CC&Jn<;!X+ykxe!499i&2!LHfBHO`<0_a)99CCpni^cF0&#X^*UY*
z(JyU7BMfUDW^3u4W`&)AkL{fCY>`XS5$3q55f)O^1PCYWw^dKkPv&BN(5gkrSK^;i
zq^IQRT>~wO)VxF`C_Tw1eJD7@ZIpcM!&hFvEwWYQvYH%KVV}o+Q?n_tff+-3%<fi}
zT>O^B)5V*GrhW}+`owwGoO$&D1Td{T4NMM|!FOJzrinYmr7B`DlbbMcW=9FLCshc3
z5YtU#6gIbR{^Y$JU~P3RjQkd8Lv(rjT@gKTdKlePA9=TBRJ<R@<l7n|vjZPiHQCJ&
zO3Okx#(>ToHQ6LF?ZUdul27f%_(WH2{_CvhjLoS|<MJclx!%la>X-ewn{SHV9t!pj
zgPhY0Z?7=jFB?k}7bx(ySX!<wkbrld^o7@!i*jY>kg`M%P%z$-5ROtuJWmn9+7L75
z(wrf2aPrvsf{La@floDzW3Ywj&xn_DNxgSyUkImc?6Oo^>^qW#9O`(lJk5dNY$ur5
zHkW!CdXC)H&%dG3uR`)Qb3}b)km;fk&o9~3P5&>!p>%I9bLBCHY)-%AR5R*pFEFo1
zhEuS)N@iPISy>n4P*7TiS!qspi)(&eRJg0DTphED{}7dt(yy4Ep}Xogz{u`X!PCcR
zgv?p|da>?ng@Uz7>IX7WP?My89N3M#S+5v_kbHip(u3&+PVD%^_IM9Qvu1Bp<?%<k
z5#FpVI!e|zDlsX_xfryO8f|yO?-CC<k#guaIvODAT{fy1pKtNUP~6_Bf6?TaBuuX_
zHdz!q3r$2J2OZm7Ed-}XUay@`Icg&wRE&7?=-M#O6DG*8zE{;I50#qexGdgU-AI0;
z3~G!0sQk>YTl(}sO(4FVKDon1%FQi3cWgTthqF6N$MsDn+qjRsbZJP7Z2yQ;(AGt@
zM7md_=Q_f&$||61Zzo-?!>XO{RNShfvh3K|syGcbeURR9-=jG@c!6qxN30G?$eZjh
zi#?nv{3cVfd6`+ij1Ca&W#Z^h79<A`Q0m?UhB#Fp4tp0xwV3vt`Q=%Y>$WYpPdy$I
zaXuIB=b0Hde3T(0See+`PP0H<nM-QiVUwGeXN_ze6yD4e!>e?C!2Fo6ar1Df(y`g!
z5I+$0q7QgMj@v(a|Hi;ulB^TV?9=wzwu3zW0qf=f%k~A(aLY3;+@bfK;9-?Ij8%5e
z`F%$3-uS9Gd?mkTsLI8=td^7G+~=rrSkv1d-$o^eP0hc5JMl7Q5{b8P{Q9o0?8%44
zICakNapE>w-}d_jT=1sJKGk9Iei{C5_axL`8MXTn7h`9V7kEoSIHJm@eZ8`zg>BJ{
zowe!4?X`l{Jdug<!6XuF{a3U6!4va$#4lpc&k#K=QC_<JEvesUCc%P13{k1&>&)LW
z=08?i@&d0#&FY%ELNjoQzcOqyWe4{8wK$X1Kv;3u)bAy|Kg>^Qt^V?Mrfuz|avB|L
zxDo35ef5tbVLC3_I+dW^u}tdXwt6o(bMtWe)JLy%6C>S(cTq#csiZ3FLlXxaQUa&P
zr`*RT{gQiSk3$L%avXfyEuLr|auiaiPzLD*fqgcuCf<=cQ_x@-wqr?Zk4uCzdk$%y
z)kVK)w0mbdSo1PxMtgeh^7CtOySg4*>836Uwh;|KyJe}t!^%jZsPuk@IqY&z4$>}G
zX@mdQ(B05^tTVx|%L4o(JMgY}n4ETgme`p>*kuX+QT(|1h)n}*L#ZCaIfRCy23-BY
zXDpppYGLWQBi8ibR%aa9`#T3#i=tfegFeD<o+#`Kj6S^{GLCfyiIH<%IgdLTzz(wF
zHo5c{BTuL(Tt}HroU#1(jK)_SYVLRMRIU!aJ^P}MX}^F)vIbHhA&C-obxO}MveN1i
zqzYmAByYKq8!7wIp-ViPWD~18raYzU<&^DQFXvQh(htvZCky$~@RI^j$<15@0uc*2
zkPcAg`dn0u9UhmdRMB5_z;%OOQ_&vloSi7V6XQ)3^P|rGTt$&C!gUFqP%=jG6kP+o
zdM6VHHbIk&>`uq=2$X#;OlC2zHL2WPwcgQnz;EoF-t>Lw)+dF7hpJ`dPD;j)dCF~%
zW!}$))f^a>vkq3V!$fc08yGU_)J#!8K=eKf2#|`n*$`x$wK}=w8tra3Q?Kl3l*!Pl
z;JpSI#<LnUm~e6r^X^QgO_dPszNfDUj=1rI5)0ndFj#HtT7t4}<$j%YDt9|%+J@gv
znhZ+V_cCm8E0ZzS;MLs4Qaj}iSQLBr<9!xl_p_XZ1$lwPUMpB*PUJ=6OUrJ@+OIfC
z8t0EJl_sd-!#?a^d?Gx)ChhK#<qUEXQcj*%oM`JhoYQTdAjplzh2Q_Y5%}VH8&*gt
zWz^x}({F4pyY1Hu9hQh{_S2VF`2Vu1;#a8MARX>=CE;tDffQ`t$VkVmxoB_U3S~Uk
zP&!d~c&qe#Ap4-6-S>;rs~YzgB6GVg)ZE)=>fSf>`&GmSfh4Z#J@orU{aMWAq|Cd{
zE09I)pKwR@CN(c9d11fcQqiNl5!O$pN%2~fVOGn;{EoCHl<;Mcvu_>rsfMO6YiuT}
zUGh`iW@H*)hEY0M7Nbjo!Uncs6Hu&8khVt95v~-20O|zB&RyGwYL+LwRNV~8BoZ}E
zArlnWHO5f}){#bQcyog>vUv~4GKp;Ha3wtn`uGW&;wi7E;+r2|UwS&Z6rgh_p@5=u
zL@_`4_1YS{N8M%!oT^sXRCrW-#)*zXZE@+7`$v48WN$6#m@G}K+p`Cy))t7=y`4cF
zK&y?LXjwSP<bmGT5DWf@*!LxF=DgjO+i4)fej0j|b}MqCQ)OL$Tu!LwnELq9Yhmr8
zenSrdfi+cP-L3h!PK_liodA3mJHJua-tzAD*@3-*!}lb7Sxgz;pAI2P{-d7x0Kdya
z;(LUN8IDr+&h!Q&4dEvfu<u#31vq}x%Im%Nv!*Tbv_ny!O4ZrqUb@c;bar*mb2l+D
z>kyZtpqIFO26rER<KA6(m9x@&FDj>~ny9ouE%VD;;|l`6@>|SYT@&RWr`w;mWsdBj
z6nuSK%uY?;T?&-*oP3xT6Hpb)gP!LtZbAZLS}uEn{dOV}XT?eI`pHR8^b{}bTxQkw
zrheoi{nfwF6oxXNga*FFRc#Ac;G^Bcq4;{Rz)n@5*1bBf5hMTKWI%w1@4TN7r{JIy
z!Dlpl$B8cA>4B{jvR~zUwaL8ayc$`^rm1!{7@m@x7?JOi3K5saK3@`bIpQSik7Lvz
zeB3s_P{L1sw4ZY)nTA^u{vfSc`>rHn<Mje&OtjEx)l!h?eQDOzTO3AF-cPezj5kV5
z*tqnn$j-sbE#4eiZ#ZY~dqbG;QkB=qax)A(^Qp9g!E>nahFK1I_J{joMx3<Fc22(d
zwQqbbIde_w2Tfg=X4TL8Z(*){&U7a?D@_F?&6UzzNx*W!FYG4U=7l6WpkxG@1=nBE
z=e&hdG#?h5Ff6Yd(Tsc9K`*Y?F;il{Zk(5T1XD7p@l7Odd?umnCPZpLTp6Lwm2usc
zb<@Xu(y16V6c;x;E}q7}cH~SautgKznWkNmW~<Ung}{neliq4tsDI-;^6|tbME$gE
zr|k2}xA=5c&ixNvOo4G2Z%Ya{Px{GpyIx@U1&MxX<tw)6G**(&)}Rr8@L8n|tDTE*
zH{jX}@0T?xA{nnTd(U+Srf;R*8hcTN$O)(>#3iIkLH#8%72U&nKB}Y=p~0O}AoxLd
z*2Bf}F9Ba`>U)bP-vf37G|e+_TJUZXlF~AE63QKp(`FP6+xpW^E?;cUhY%=?!(xYe
z_!E}_E^@}GC$*G35{H5PQ|ckhOoCCVoa(&?xzA#C6BtEoH@EE;kyH<G*^%9_6Q!!>
zWb~wXqo@^|)W(?+J`3{|ziN-Yd=d;6-_y@U<R-;rd6_K}gDr}u5v>T0yCI#^Z}1!T
z$sMa*=Xk8$p0M_}F;|ET+krkiGZ7>fejkxznpt<@!YCJxWs1^yC&la}soiqpa_o(G
z9~V4vur{MiAL()|<sqXQsuLQkOJ8R|0GQal(?l82%XW*Ku|3)Pk)~7m?dUxBvUAl;
z-%a9r;wD_a9HU0%uIN)ga{pKPYz;zl25s6Z=VDBIHU}0p#ndJ8RRwAaRH9{H89dY`
z3-8xcm_#|1^!cQ;eAscCk5rCs5Aob^(kW+Y_nw62E|lSR%PObznK##zx_R`Zgxx6#
zFC;|quBBMi*7#&=a75fQpOECQ-3ZW@SU6d|Km0w-;~4Y8VFwoU*|jc>s)uII>}8=<
zQ17n(PNQnDTPBU3+8voS-85ENEPbs6wVse8vhBA*KQ5HmYC9J>YEAU@nD6YV_b(*9
zd3bU|+lenzYk0%<`job^?AiFyxbdX<o^bgQD!_1X)3NQ^K4rQ&YR6qqP}sXr6x+J%
ztz}ppqQxuzs|B{f4dK<HY`ty^(6*leZjVi4!FcG?9cqOIJ-cLfuM_y3DqhpX0=1~q
zwW^2=Rhv85w1ENoECwk>`&9cq>|52v5_|=>yO^Gwmxr#@Z5=x&vNDJ+LIpF<dysT8
za&s>til!5AdaD!Fk9JY4+mdJEdRiD@D$uW8=3k#Duke(=Z&!PcP9`7ZU*8A*Zt{~j
z!vdC#S>*oxx!_M%zd_~yV#@z80l`I^5Jp4H<iKA~n86!_XjT$<l!Xn*@{$2OSv=rJ
zM88GiU^<fDBr!meEds711z2;XfRJnna4p$yk^~?V#0O@}hybb_W^fz%m3S$K2nfvK
z0h>|$X63<PN;DY)4*L1f02YKvfRkJvuoBhZY+#-Un40>^--s9~aFWLZ4x#zY(g8`u
zM8N%gX7CX$Kwh8#EaeM;t?1FDHyGpkRU`gFV&GK)5BTeUSOxGGwku6Vp$Ish{fb;r
zCI`5Rc)$%euGoYk74Qzv6)CGpi0)1X+$d%Mf8qUGq^pIGcFhCEg<gri77Kwrevuv8
zB!E{554cC*N~2p!18k#NBf;OS26+D$IZ-MJb`nBMrGSnya^OxG4|wH2tO^(|jMgXu
zod!67b~z8&N#r+6dNtz7a%Qlv=#|LZ2nUd^-~rQ!{bor4&r%|QtQrd#s9*pO{uJK=
zcq)0ogE!Hn-rw3;6B3d?SHN5GD+82I1;K_AS7f#6FIxpqnZaukK-bgz;0;N%MiSVo
zA_iisc)%l4zgY$Fu=H;d7x1nY1pCVT!QucPt3|*ZvS<+(P*+0>Sk@3h{)Hj_84O5E
z3DAGW@e@wG!tMTNI1$LJ<pEFr>ioHulT7#@RuRfqR?!&Z&HrMEfBr}QjUoQopF!oS
zI~q*n{hz?ZUzPzmf4YCnblOidnvj11ihsHS;i+BuLSu`zf7YA-E4KLOp#Fs|{=-p}
z8gNiA5Bb+|<{yoWZlfFVqfa*Ee1BU0SB?CSPELAPo%9>&Apfe5{?V|>02oW*qS4dB
T#`!51NB<!7AP|=6PwxK!3t7@Q
delta 19250
zcmaI8V|1kbw)Pv_wrzFTF*;_)w(Slowkx*P9dvBlwr!hlp0)PbYw!1rb83vbKUDqe
zQ`P*<>$>K=D>M;o@E9zPl@pHSe>}*|P3=sb3|&l3NL-yQ?aWDR?M)o)O?Y{24XsV}
ze_1-{|N8|v;58yntv;v(G^k5$5exw$a2tmx0SgVu&CHpX_v;*qr89}ET`db%2{@`s
zExTqWgoaug1PF)(76=G`0u2d}z>x$<gGUQ+X=qj~q*IDf5&raX&o@zVN>~wsa}g!z
ziyLa)ZRekqLQ+OukAxHn(T7VTU6RxsvqiCpH;`|IX+nbw5!G{pH)UD67@_!<w(nEI
zLqG%_m^4(FN;{)lf}<IwK#I`5KSU8eZDSEvP}F-XvaDr-f>2J9Yu^BwT=e{>j8hXp
zmiR{Z$E5#PiZ0crA`ssUDfI_gKTc4Luv8>&^Luq+<bV>QKAdQWO@&BIBt(4?`*sik
ztunWj4qsZ@(_c4-uFo?{Ci%QJ`2MAsbB4@0TwY}L5<{WLz;1>&+6{*6VB!5!Eg(%A
z^LAx34$@(oRIxYo4-=1`0O>;7gj+cPZw#L1=0w!UKJMRQ*6BZUW-~np_0#8wzpt}0
zMThwkc^fsFQFJk7^NcfwT~-#1TSdyS=nh{L%N6&VO7s{GoyYL{ON`FwU%LnN3gPQa
z7;4rPy%sL4!o9o;<91=+-Y)#5+c<(F{O^Q?nC=5sCewdz!(m1S4CPhO4tcKve(G>I
z1lwl)y5Vl{#^6d&Y)tZzb#w{?Bh)ynKqdB-ToWvo`#Wnm1)3=a7fgkaD2y1kKxDew
zlghC+fAsKjax;6W7_;%|<O*t<@!hH@BXUwbg$q0Pz~y$^jicr1YOsG(G5Kwr=qF~T
z=(FYB_00j7MwXkZg|qeS_OU|-z}zPT{h@7hs7)=|TT=D9e)iz^yyfLbR44VA<lQ40
zt=uk|DjOQb>>;%Rb?ELAfhZM)p`=9@13T_ChLxg3U!T0P%4UC0#G0A7NhE@Pc=pE7
zas5y@e|v%S4;l9vUlUcwzg4&Wh0(v=b=Kji4}7U(vURwzm9KHw<?z4N0{Gmp8n)le
z{XX~&H_YY(9g+JvAYh7ShiKq3{Lff4-TFzkf6cz-vL=`{B@_?MllO6_q$^JX3o9i$
zgzrJCF_B7j&iItLMhzn8{q-l?uV0|XK1o>~tsESpWkBW8m8sXGR+3+|waehSew!p1
zFj%UU4VI<O*51rX6$NDP19T5xZ%B3kN4V)wX$F##{gbQNQ2bm)X;Q4@VkS6g!NphW
zKyFw{o+Zj2+&SbO9t&?pi1c6DyDN5XV7ZgExuBP`WTASvZ~MhW--;Iw4JF6e7AB>F
z*eR2DS%sbg6k+{1!8kEpOg6T)DDH5E(<DoQG&ucdLS>~TJU=q&0m3X<N+KRti)mz*
z8;;)}4qs!*PpJQF3cKyRa*p{#A0E^)*E;ucg?Fo$N|9!U>qu;UQ(L#&Mo*vu!j}c(
zEm)sjt0-qA7pphs6{J)y0nfnOCp%>KPHl3%OaCJByZ&j{h$ig$CHy4bvT|LUhm5Tl
zDvZZ+FIlL1G5+*11ki2u^m<>MKdQlPS;swhW!Wta(6_gjQ1t!iiz|CU_h~(I?}%Qh
z7>T}GXx7a>ZE2^9$zLSCTK}zYmuq5<^Ow+z$zIM*;!QNf3ynLG&fJ0+rT#~<O3(Yx
z-<REKf>?4L@q74EUzgLkJ!FOG?%Z0%XF=$}Ao0i#<eu(Md_@^>2n-Mq5Eu}!2s+K;
zmftVn;2<FO2w$lBFH8X#?VT*mE$s|#K0m+S0tGu)U$<UmK>@gteD=ogm&FOcq)vw-
z^{6GgRfj~!hvaG;iv4WRk&;ir{k-IplHYAIEj0GQq2Ch~SbulX??k_FbHduJ!3-E^
z6|sQ8mx&y3<6D;>Q0AzM^~0w!<Z!|lR&?W=_SG(Io>`!U*ab`<1wC-d!Z#$Eyps<u
zkr9hjEhY}q$*CUvB@0Z}VF|7irp>qC&vbwfg<V)~V#iLKp#|<x*Y>2n>K^j*gyS|B
zpb4SZ67W<<1!7=*dj@nCi=R6{xd)S_Jd_$ZBpI2lH?xqqM-aT!hXxkytZtd_0Wuq#
z@I-h{|KfWYrvTbLB^NdA*(n~S2*gJ>v^%hK5}J6$s_Bw?{urt;OB9IxcG=F(Rk(7l
zqSeeM4^}cS(WfUCVJwS4B=~KWsD&1H(}Rb+=HV3bp+uqB!argXr{>y~$5B4iG*6~~
z7Eza?c#_7^VUft22o+nuM<%6sDVr13VC##+Y2Vi-A_MUIYYVv!mg$+Ky{3HTjdZ!O
zrn0|S9!CHJf`b!ZQOZ>@LTRVSt7-t{<_cx_(0(8dlQ-wpnf-mr@X@mZzGL%@bMU#A
z;b?5f1N{Sf@ahLNe<81irxqB3Q8)v6NMd%rSSle6<wj3*E!^nw;plMx{STUw!%J#o
z8h6jaixvPLAVWtdTA1qY%JS{~^qGPH0JVRAH`+fBy@Y^#UtSK1f#XIoWr=Tbk!9ol
z7dyGAx03D?1?0_%-J62v9&pQ2{C4PGYt<d86OkG(?`8AN1|ieI6)YXr2yGOkUM;;C
z+l&Nrm!nQh!e=nebl`-nA$XvZr(Vx|A#$AI@Cp!hLR@va8$)1}WE~(=n=S~k#5?;q
zB(yGoswh*N!a};<Uvh%<o7tC$CEf8I9()V(sB_dba)r@owq2-Cw@+F*HD=Yncs~!X
zuyV<zXlgvcdJRSurx`LPe28ZM!s%L-1z8M01k{w%RX@UoA4mJPginZd>jBlNd=JP!
zapv%-ew|W?{_a`@`B7}q!S0Y~@%MRQ>iiAtKeYq?RXbALt~!2SExr*R1mqh~NtPYJ
z<YMaVlBFhNzsrdtAk%3?H|kJRibhc)63WlC(hDZu%8#M<EthgcNi<w5VT20iZIh3^
zkf;Hjqk>QajwjaMtOM8SUR(?MLXZ0>_^(_ebcr^kYe8XfaiDcUXr)u}@#S0k5nW;m
zAx_$G<s9ZQ%;|hoU7*t+njEp?Ird>d0A@vyH21Y}TTi<(;-C3~CXQGeA=)S3O>Rps
zC26;r;mh*lsoj40RxibGRmo8Ld*m<nRu&o5nxImo7;MAY)UgmxY%$Y2flD$FkG2+3
z5bAVyyE{#yq?ZZ;aFCwzqrTgeF$e3#=k<<tm)~yRL<#ueX2Y^X)=Tt~<<+<VaTJmJ
z%8eBlLy9Iv@M(teG!X@&2v5h*V@a+_98hT5MhUv}sRRu{1XoEcT@A-ph`y~f3C`nL
z)ibB@)WlF9M#6YrIfsU=Aa`<LCU2G4sVaPm1BYliSQ)zUaLaJ_n-@tN!V8uN)#_lk
zS$U3<n@(O?6CZ5Uc#y=ElEq<wU5oyP;AibNvo8DGxu^8Qq6=PG&O%{Jj=z4PHl=&$
zHa{>!TD!K|W3k|xXk)(rjOKSl`*Ek+o(+X`^d0vsW`pf<t-ysJk}x`H7QBXZv?lf{
zJRznl>Ffc9C9567!F4S<gC`DgZl&udOKIU{|7jU5ZPt^l5z}q~2cK;`V3|*sAN&TY
z-plYD^wcl8kmfSatb-AR#YX|9w@M;qhG;T^z}Re`K?ZDhxc!j1cG=?m^FAOoJWR{5
z2t~B^5(^S|fll`(Qkc`*F8{+J&u(FREPuj)o*O|=S?`2`;)Rrl<<0{0SrVAHTj_$g
zZPb8!docDEau^C-16#=nSgWDm{JR_aW-GJJV#!QE^y;gC9_2p;)-9;WD1aS=EiVB2
zLX7U>c0+Xs-}gZkFuFJN=5Lf9B7BNhu2SamEL3Mjn~b^zd8sFY#hGxQv)nSiFrRWi
z`TXMC@xf2~rr68Cs-6&g`SG;2Gi}^=o0t$xDF_p693ZC%{5*#Te9{O?7KCTHEp7LV
z+7D(0Ik)c)ie1NVGrFm-Z#4(b`uHC!3WdND{*vrHnrxbFz=}5dU6)_79aL#B9<uNm
z%oJR5tHBC|Hs)}VQcp>0G~%a1r+62oWdjo$b72}5AeX))TQlIO!S&j$2u7DW`PMzZ
ztWbqF@T(h(T3Q?raEKLemK;sUKJzF{pz?iAPq0uRY-)I#+mBU=n_(boUZT<6H@{%j
zC}C|ouM@?Y7bZAKb86%Rs=<?J#KeRd)fbAZ@dsPuAsaxB?Yj?+)ia{<&3B`RAD=Fz
zF)4nYkW~~Sng`B7xQZOPlW3fTPs2K8e_4YzKURt`U<4eZ0ebd8_cUB)M@e%w&Wt>o
zfGl^&0DdJIc8Q)&>ARsytG1WIk`tX{u0W)*tf3v-ka&#~Vb%2k|Cu4SN`}LLB^FL=
zm}|Iq_}{JHDScTxdbumHuxqQubam)xdCzvS1(}gRG*NEeUoo*2=q0VUC0|oU`?@!&
zvGhM-^o|AWXm@*WoV27Uvvl+nb^##&n^tjFfmktLv?BQG^aB5()qnT;qW{9ys^4et
z&*W_rB}z&8U?eY{x=_dnH!qqtD<PT0iV(7TiX=Idr%v|}WGP<=IVJLNOednvF>m(t
zeQZ01CH~qeR$IJg@ZVaXuH;Sr5<L}a?SKB*wLk*~OoDH80uFFfipnKJajS}(j{(81
z5pQWpYHe{0I15gtsiuNV2QqC8;+J#0iH9%4nkZl$m-wS{gVGmmk{`MpXu5i~N$Y{7
z>y~BL{(_`_#UTxz2bggfMx?-r`>g~NeddEmo)vEszL=+u`{)A$8UJhsT`7z^foF8|
zxI>q1WIgQLWsmi`teIqpHm7Vr7vPn;7{39t^nLAm=H>(`!Q_`-d4uZAayqV^XhhqT
zO$Y!fl4q;rl+}JfO~+bNHXOE5wZM5v5ydYy2!b>E59ZTpz9dtrUD~!@eA~0b6|-6i
z>+5&qMaVcn0?92hVJ}2R_KYCbTix9T?r~hbQ0TaPDWi$9VP=*=>N~=?DBvY|ch$uu
zRdWI6$w8D2a^9%HWg+b&LziuvS&~8E(6g+tuT2!M4vHK-Y$!HDu$StDdkCF?NSH&Z
zOV{zNz-lZUzwJ?QboAK4Ka0A*xv*rc!-YmSwtLbDRW){RsOF5^JO7USSNA@WQgJ~B
zm|aY(3%^8dh?XUeG&JTTKj0T12fZm~C;AAt>RtG01)Jn!MY$e`RL~0{`@xoUzyde@
zqaxpjoREifPFIM2JzX;o5e1LLMO`gJxUCS$_X5JsdgTv&W+~XTW++WKv6-{I!e48?
zB1!tCr~}pZvoI_e(;AtUbBr4ZNRf+kSyD*hzhse!K5ckzQK{Qq-T_vaMgwhpTc_;M
z)?5bP6I~q|9@^UwvIqqCoK)B%hrL{dc^@y2qi_%i6=9&uM-F?0Lx2iGpM!oIo}TFM
zm^}dW9#<!u&#fK2VliucIt|*N&yoz*w3%VoBkOviSWF4?Im_kaYV#@clg}s49WVT}
zJ43xXJR20moA0o+1Avr7GiFhv;)b_OlZ9zpzl=9z_dA(z5oJW1Z|_*hdH}u)W`fTd
zAH>YqMEk#oCs6vzPe`d<ycltYdap<`R{=vhkG2SS{Tr5=Kb+xpyGL-f-m!Nu{8#@v
zAxTxETd^>*hof5m%GCF-I{fb3;6P9o6Dpahs+$?Pz|DASwg|8u5rN!IpIYU8J+852
zAh2<m`B~`HO_eag?M#hupCt?&ft28X6g>$HClrWe#{-5KQ<zmPl>1x-5@%r-9ATvd
zhi9q^(`Cw1AYNV=01xvl(%lJqhqf+0G>$%Wj;fS~qNyTs0D*~_$X)L}EN#KNCoI`p
zyuCr!1UZIGL4fTPD=r4uVU4CGrZIg$60LZkzK2BY<M8WQ-!~Lm`2`6+3@MJgN`q=8
ztIAM|w-f_Hw8{u;m0wmQbMNO%;Cav=5Uqwb$>rEdI@&03WrrtcP9l3@J_Ka#!U$tD
zX(eJju{SL8b;EXC1j;EX0qo&EA9&Owpd|1C9lf11$CQ?G>)Tg&Z;hsVEDRLpg1yEd
zBJhHhPNBQ&jXMF_0_(omw*ZjZT1tCPRHQGtm8rT;yYvMx4#a<16<Q#tI`;p|suZbj
zD(rEh_#&Zw_Hvli`!SJtjP>$oYn3IHCx@zeY46Fk*&q#0EF(dSymq<|2=17qz!g>+
zpr1{$e^KlqwU+OTVuZC*?6z9ZAZo5)4Ha8ZTCj^+h&6v(&M)6_fQUQI5aTjT*7H+%
zW^ZhO@o|zr+Cw>-w*Byi-PJLoy$r7|znnsV^*C!aMAtfkJn$l2vAWjH$C~3=*u#J@
zwfxcB=o&s0Z7wZq?`;Li+;x#ffm<k;V4a~tXZ{w70qhd$qdU7rGVusk7K?Zk8Ggz6
zRW&JRy_O}W<g32EE>^5ADMhsBjO@kp25~L`(k*PFo5_6gAD6zKDyT9W5uke1UOd0U
z*vMnvyhQ_+n13<F%x%1r3#_U*y6@Kg9fi!S?IOJ`>=w5AJmrKS>v~Oe*Zkzs)Xf3Z
zjW@5}?@E=K<q?F&JQkuv)2I4D{kJ?GBfuuR>|fkckg~ndenEcFw<)}GH<Z2;;Zj6E
zqH^A(9?KYDxegDG7~Pk=?ptg53QMo!L5n1k%%~P<ih7Wyie3%7dDgN086&!HfWdWp
zxfLbl0Z2sk2sGziDm*t^oE6gXw>?8V^n6CNk?NKz!3wQr)l@5j45r9(%}bx`Nt7tO
zrT9#sl{7UaHD;pRpTV^hn<w@^MnX)093aK>UEkA!gJ|DFSMasbaD%k7+GU&2G%Lm+
z1^>)qM#M|UDp^{F=LB2#OZF^lT!2UW8ukPe=!39+V%z5!p{Yl<U;wtgC>Yr(be)k+
z0o2@06}Mco9&GnMIIDcnf&gyP;%h3&in@vh3tz1^cOw2KF&|?IvAwP{pG6u#jy#9H
z&T`yelHVlpb=u5nb;m=dd1p%7Qva8j{p<pd(KBvG5N~Hv*6(N9PFYv|d;yLqd}6$d
z$*0rn>JrA_$+aI>@^;7;-IrSPYh(Cwm`+Hf1x(aOebE&#{@#h7v*cMwfmqW^ftf?8
ztISP1*a^B3CoN%b0g2K5$v;*AcS;cV%}T?h>am`4Is^3sQG0<d)btM_j28q7-ky7g
z$9QpvH3%EYo<D(JY!%D!eZa-@STdI38UMBA<ov4Oa^f-y!dd~Mfb7;~__Oc6WcqKq
zOf62+YmB~?Se>eog14^UkFO1!#D@d{Pry*qY)cp3`u&Ii!u5H(!i-PA7cx)rT;iqe
zLlBYLK3K8I-T04*3jFeYc`-`)T>jq6S)4B_8tH`+MNDCjMqBAk3E+v7y8U^i7GOAQ
z>|c_^nmF3g5I;ROELT13YI0H&`azQ_S>z#8xgo6B$c23u4vUn|!?(5p*oG!9_-$p>
z&o}^T9vHR7=X==U104yFx_o=px%}WGl3n7Aw>``0yWD6buWOQ@Lfmkr;{FXr7bP1P
z^2k+PULNN??iE8J-PD{FXcsH|NfB4D>G1%`Lwx-DI^p3M&XvOv(8x*^wRln(+k;PB
zwU@X|<8@HdITDcH4IMLmYWu;;cYP71OldugB#wsYLxY3ymV63e#rq6H<n4+S1s4XJ
z<?Hhpo3}!V*3m+Vc*eQ}FCG~j=PV8!*fC|4e1vOfD=@*N;HtrM|6%YAY3AV%q&XVb
zk@a`D2M|+`mx|{k3FOEls6n$U`N8$U%8ZU9>ZW2q&=plv&gKL@Q`7$J>+|t&=YK@q
zKTJfn;B|C*00RM8|Hp%ZKmxBNh=3>tP(V!`G{EO4C<w^8nvC_T(7)WMq7Pit7J;sl
zMR#4EJY2LTZ3C<I`H)`C4BbkSiuzHfyF{#{lBgp|sB%E{vhKL|?VH(t30WH^Ul78j
zQxa*DB46FaBRXn9Q6r283SO~_KqWHV=IKT`_qVj&$NB@8Uk6^$@w9*E3t!p$r}8oZ
zLMV4JqUeKEh9r~u<hz`Um1x)ARd+rw<_r!D;|-kQ!$x`Y%-b0BYWB;fH;Cv?y<&cx
z7_`zT;Sd!BW_u6s*;vs9uxtAv-p7jFJ4^$8@p3poa!<H|f%@x(A>;krLBR(!cXXO$
ze~sp(Rj5-sQS5F*v?rG%&(*C8Z|?5^<hPotQ`tXB>%BFavL#ApJBXJCVqMl)b7XSy
znf5cRRwl39+H~s3eQ8knJY@zmYs+wTtJQdyKOrDH^XBG5O$m*3A%WC0rgZCd_eb(H
z^CH@n$VG7V{pk0F5oG_0p$X_71C!b%-H%`xTw+BDa~bKwwZAJ5IU#;!HUO3IN2*0M
zNn!|%q_fiZOsQ`~inTN_@V0Wo%avtK7K+#nt|wB?QQs4yDSq1S$Iw>h6bM1x0>ACu
zMi1qsarW0E0g(&{tT135bFb({>O2x{q3LHz)gzhJZ$~o}6d5)Esgt=Dz#kPZ{I3F?
zZQ1@Y7Pp=cyQ{CBwohOY8G!!9(bHIm)bGjkqeO~w`RM)=p+eRVj!QM(Y8X*E$!(SO
zp023~4~KV+2h*aHo5hn72W4t`Bx&0uC&wDxzyk!fyf6kb&@ndP^!FZ!I@E-LIO)>v
zLWiCf24vmrZTRuLMcO-Ml`wu?<)U66+vB>jpH6?P&g|9)zOks+_W+jGK2QgRn8Jc)
zy!F$Hqtj)y7GQL_KRFBZGbe37)Cdisy^EUVz1M;yRQzO@(|!7lS;LxZTqvi;<IFr1
zsTyBk(8!Y%6P}$)Z|sPlUJ(K!(i3zRib_{{PBo72>D}4b^=Y4om9P4ss)#nNr?B1_
z<!jp?lbDnWdOzG-J_-Iu)cH@Xd?M!T{}XlE{g(kE`R_vcZx3{?zWGnk>HDvs^Zx%1
zI)nbdf=&tvfpwo2{Y_YRKAuSXWjNtoT~dyK=pu3B)+{?}V_LkGA6<w*7J`;&5}MX5
zi%!NF9m`XUfNKX2=~w(>NPxC<%}2bkO+0e$qV<SzQZe1FM!c{LQ>w^HF2;1HlYCQf
zFT|<MT3V#+aiY{UP;-0iz4A6YvoC5*2{t!eGloE8Ko~AE{jF1fHs6gquvH{p#_K0b
zlQe7Xh0YO>PaKK5KJ@+HK_~Hqwhm%$=EKt1#90j&@-gqFEfio+AiTh0*=zK1haF8l
z6h^H`IrW?DX}?3NMH15*ekRJ>nzeNDp`_v5GEZ3&a$fS!eyAALZ_<pglAeaq&~|M+
zqMvkVH0wmBY?8luw-oVIP1da9ncc)!WN7YX@$@;Q38e!EwVdK9O5KYUBvv^E5i+=p
z^ztaXmKp-=K;;4LBaC*mZUUk1_7`P0)~b?75FiLqLuzvwYWrwhG+A^k;H|uYEU$Xb
zltGFo?fMEtN7V`*|9?T}o$>z;I>$7F_xEn+pKcDw6M>PByQqn+-<92UV>_amtA3CG
z(0@I1ynNgn5yS|F-k9C&-@Jg^K!yHNod<zK;6pq5gUInH-_W`QKRRQmo&<me@omQa
zo{-sm_+6Iv^L4#c>xwLe%&c%WTMH2%yhJA}z$_rFk4>l|sdzgWSF)dboFQIm)zK{N
zZ%deM-nBha#bW%u5&0<3_oA1<)0ZZ4fVswg`qs#w17y&Ki97xo^+pAVxtTLcSxNWH
zvX<TxuN>$oGo4ScPkq1lR-Fl?vUM^}U3jrI@jn#7$4!J5T14f-ClPX7aJmf51JR1X
z@!DIdVNuE#7g+j`w?cP^tZDOeuEE(gQw&Oh?bC*=vF2Cws-M*50-?~Y#Qau!XyLDP
zS6t$^K>q@<$nn?^yF+YXo(=&h)c?~>u&w^dHJM!OZNDZ0U(E(oMOnF8HS7SGqss!M
z(`5nY{7>h>`On$^E~|evB4CQH7CQ1*9k#`H06xCz5F8E!g!Mlk1k&gs{kvslsma-|
zaiZ{l1*jx4OBAIxOFsym5LQI}^T+doYri$2xmTo;VJ0});Jkk2rxcXuE6@d6q6wkB
zT=oKGkySIESC2itG=EO-LECUK&b%lI@9--Bq`4g03T{BAO%a~RAgV1WHx?K0_XOLj
zwMcnxe8s1y^X$g~=zzc=d5>!uUw`Y0bdSZblNkXvKjo|2j>nnk{3IK((VX%{i|gKr
zCoe^><OZy-_;ls+k>yUI27E?@4q`ajJW}k*IGcPYkXw@C(fFhSVw0|J_g1Gsxtf|d
zIG~u+5v6T!xn>2q;BWRq??mx)qIqo3gHegY<t&XhbE`E?1R$yDTdx5JsHyx54zAj8
z&3C>74{{#IHhf6lBPu6A_@n2Zb5~@8Vxcjc9rDOo?gCUrv~=#R>!LPIAic+r`Hgk1
zae3}=di8yys)u~_tK$Th2G4ABYy_q=_iHQ>4WWv=6^@E&Jl#+>J82Yp-_#6wfo|KC
z9&dGufajp<V8AIO<N;#t7LAJUIn(a6_Ib{axs6FX)7_x`BX4sm1Yh07oNf4E%rx3E
z<e^-hKQ`Mpbx&OIvxsNW!90{x!-_BJ&d7>wSDGk3b4mH_q5PQBD-eslxYSR*>1r*r
z2i8;c8#;^P45Vyb`P#}tOjK|97}JYURx+?+yho}-MS#zMm(JsMP4SO%*)^lRtU=tV
z0_6#oC0%C9(Ym0X?-)OdvrT8T5X4w5E1m4)7(;-x_Ilm+O~l~wavb&BSlkCL*b5Qn
zl0H-H{avKmEyh>;JnM9`0*Y8r6slD3$ZapECrye!Kj-EZ)z=qK7K>ln%RcBD^7d=a
z0>JgXeF2ZELAw5?HBBNr-?wyjZN`5_e%iu+(hR32^32<<<ZbOw&i3?{6+E*p%Fv~N
zMmlcp{_I<>-EmnHi3ZJ*pxHGjcQ5vm@P_Db!S9nCk0_=aDAP+B;luzb=}-5^>$utc
z?OL8H3?V5D_)P@v!LZ?n36B!^H7eJ>Ki~A&HU@Cc{$cT;hr{tFxgxxTR2X}!OW%(L
zS{-Pof8#!kGsE)`J7bcihFG0Q=ld?NX0;(!M5Bq3MNqZfU}+RqK|qOCy8Ut>c6d-f
z(OHXxehGG&z(BpTt(c||=F-N1_Wdl#Nhfj{wb03>v>RWYW{xtwtW;d%qgciXf|#aY
zF$1up%W`}RA`{<*g>yr;(>99w=ditQ7`=m@HO6DBM6~|<<^)epmY!V2f^7LLKJrKy
z69=-FbhErI$DqH-F?W>euW+hh_7>RtB$y(iFz@`ZUzMuL7H2IfQ|mwcc<F-eUPF3r
zGvgWLZ|4nH?=Q~UqV-X!JFmjjj#nr42k)su<*AeIoZicTpV0piy8l2UX^&7C^~?Ml
ze?f!yE4}=8^Zo}J|4o^qFKp~eAn=d+eS+r=U0vi$#}T+L?dJ1i(5&#+4YhP@<lEXx
zu&<;kaSCsJ>NyEeEMJofLH<zYCb)_B-a9&>{~ElI5Zv`FshxKp%lA|!S>&lY7~kdM
znXi114h30B5@X^pD9yKQ^Y?_<LY<RjZH7(e1Ke(cUArTY@=)d9YIJm_jToUjE2w=q
z6gC19uWqM!>)K1Fy_B9*8X|Ojm#o}Dnr~-Trr-ro{oJ5+U!xGKu?!7?8}~;Er~n<N
zWcZqAng_`zUxW%_hk6Qym=p|JsGKJXil3Ow5Z$Lv@p7ZKi`Kguq&Ai13Uwb8vh)oJ
z05`!$4L%z?(#gXcE%z+74K=grehkPWhJw}jkE22BsK-2Pj6a0jm?}4uqt!Yfx^1Di
zL^95uDZk*0X7*}R0@#!|EBwj&#N3r_&-2O~ddMo)Fo3-?;c7i4)(guHdN4Cdjm%^2
zj>D1~2K9G(s`Y9SH6Y?^-|*7>3$4CA0T3Q7W1;y)(O4+Z@tf9zAarXm!5*eIL(b)H
zw2$?E&1}eRo4yM%)K^Y}C*?DYPF@A0%N|jb^XJh}ap5-!oQK~Bxgqk|8ZaPn;PCF4
z*&t5f@!z6=S{9TdR~ze%XF&vHb_WPXRZeF&n2N_gubZY(EB{4jZZ${jDd_DK1^~e)
zzONUO7<+w_5olqq+vTdCt;JizfYtxw@5(`<r3|NJf_uMVy<G%Hx)}S+3K3^&fnZ8O
zoM_%T8<ci);$OAtq4Da5sIf4;%Ih*Pt->-I#JU5i>|RG?A(kK~H`|<CP*qe(+)P18
zN<R~V?0Zk1=t!#nu2R|JH1DnZ4$!Lbtx^N*XUs)wy6s2C0el~m25mttop>AfBSmf}
z7wv*FK9Swu2E|LzqKg`PlOd`A*$MGfz?;~3p>RP$RF}n>x58_VK-V=PDNn**G&^T>
zjV+#}uO^9MOX1lWsX7&HS@YUEHe|Too>3Pb7=P9t=cUHKhgcYmd{Bl!0iffjx^)UE
z_Bm$uPTC4SizA7?e6m@;J(YiBx5QD_g=cE{^p2S0o1^r#gF<as2x*?2O8hl{5U2ze
z7w{xGCO0j6R*7EPEFJ4ryQ!)?)jp6PEey@>Qa<TogYKP=*7HeDNWc0P)t5VD;Ff|=
z5*UOeMQWRC?go*#kQ3|x*oNE7V#`Qn>bc=kb>O%o!R_4GzpMocFok8=*w*yMQ;1%|
zg>ZL>vP+;7Dc|w?uoU(-adV;2vh)jN*who56f7VWV#yuR5woZZ+%KjgB^RM{C_kpR
z!Tnanq~*%TYbDRe3to$_7t1T9)>nBX1|2EIX}QLinT$LN-hIoV%9@k2o<ur5R@s}e
z_l_2NYK`v@i7ClZM3i>n{tVM%`T+ljBtV}~93UtS@xL_xP$(|+f2}suw(F6B{!5l{
z>#2$mei`QZuc!F`kR@M-|HGJnDH+>1Ir%;ogy6@dU(mJI*oF9g0f=ZKIv`A2mh0i>
zHzj>(6Kh1~25~}?&++KbUXz!-XgGOf)iniR$!wq}MBWTLOq1k^k(=U!?A%C$V7-~J
z!C0liy+lOBZVX!idF;_7*VxhEVQ^ynY>6W;rZ08?8ZiU$nOTmcWv8xocG}zFTv=f%
zY!_VmjcA`mcXzZD7$0}!3j10b16E2nad;~@9fN2)OT2_r2G#e|RRZ+i3im<dUi_kC
zSIOae8~WYGD#iE<1Bei}ptU`{Gh_PA>cO8|+IB?AoMb0s9}E0P6`*u)V#WpLysWml
zQ@>Fps~8iQp?X464kmZwKMuT0@piFpQH?<KvmBfthV%ZgzJl?|-4BWvEMDoRDg1A6
z(<EBSa(;nZ1s?>2`M<!8`0qjad78fUt^`U~PK5&N5!gAVlS5U=_e8W`c~VH}Qw3rY
ze~RMUP1=>~ep6IVyI+o3nT|&6I<M8i_A@7Z<70m{_njH56x85Y5UQLfsA+@X6R&<|
zw0cgdW?MA)le$G62cwxbS!!E+v~w{dyFCbPS>kEx|1QZ7ns*3@gQJgP{N1NU889L)
z%}5+bLL=rRbCKKEDy<BZ!&rs%$71K0i|~6C>2^2@*@uWUsJ2R~C1Yl6<Vx<{R_NZ+
zOH_`+To%Ae)sPhw#c}JC63CdA9h&aSEt-%k`lEsi5y%U3G}5t_xf5De*HJ6ZCndU`
zkRuPAqWxNDQZ4|H5<AGo{058hRv+B`p4Ez^8_WHSz*UT=LOjT8PFTbB)=F65FJ4HF
z=<?UQK!)FHeARI6iMW?El*}!Un`~2FDLh{YFDYj|esRBeVKP;%bGPqcBRGYdOI)0z
zdUhT>;~F?-(9P)Q9$jr`w!~nicRZI|6SlgqD@C&;f~yCx)1v(e<z6RanrwKC$Tj}g
z{)}pMq5;)02s8#gSVYAS%Re&N-9dD=0VQ7i_Vnen|9N>HTSF(?mrt<uJ7m&)d#Js7
zwcjtGOSKZ5&vjVqX%*tA#Mm}(B%*sG_n~{ff-(6;*CFg~{XK#5t_3qzzZ5qTGDrtO
z*P`EL<E$Xy^XZuYBC~7f<mIt;RNqhs5SoF>Zh@v`z~CyYZ}36#*ldX*WJRtLBw@)M
zk(w|Ra_^tuE;3A3a}O^xT&rP%HHu>%oW*SE2&ZDGODnY8S?8`QuiPdomlk_8o&If>
zAo`;lO>!>~%kPFf32fY0Dc^P^^n1bGZ$zr3q(@1B1g81k0J$P{n|vWqDmdq%_^NB`
z)$pnn;sK}w95fmcS+!!$fgm(0rpt0KzS^u9?xGa&6aDs}7RGp55v@7h_y}Kf4j}-Z
z^Xg!k_uv;dY(35=)`1tqVJ=+<jk1XyCNnM7IQMC8<2IE!?LeV)i2IEmZ#CJK0kI9u
z{vrc_eLM(sKyvw!5hoOG>EU;&YYV&ZSBs9{t@ip2)>no<!g`SqvZ<;$c+MBC%B8kK
z(ikZ~sYlime&?iZ?ozC2=kA^o+xKp3L^jXR5>dwb3bM2cSzLv!*tZj`C@utE5>YZ|
z8*L^cwgQBf8x}j=3W?nk;WrhXyZfO*qk0fP4-{LQSPLsSo{w1zTYQ^ci!q%myn47U
za6!IGZXDRc0-VMhBkGs3+kMEScLM^TjH+@*I2KHH)fgV2?X8p77q7+R1PCJnjfpwD
z*Bg2YFyHJ^HPMg3zXcl1@(gfVw0Nn;+@K2-`ho>>uoNYhNG9x=N(Cz3W`R#ke?QaX
z*gR8o+YSFw=i12w^P*9)-8U^^`)M2}AV#{s0WN6|HN&jW%p}iT6;6a5M)-71sB@d6
zEWG~SN+%wS)e6vn1pJHY|K4N!M;}_=J=uwTVaAUD1cdv4W9GjF;(40wKfLi1<cs@c
zc>-(4a&pi|d{&fh3Zde$5Q#;@{hK`SkZ@m_uS@9|{rNh6R%try<}@J_NlVq2U}kQn
ze-Lk`_Odm_3or4T7C{cyE^2G+3plY3GZxkIQCH}aL57x8bDT<dyRkDd+q;1-0Am#%
z13~3jp(EP89@x_nI%n1J+^C_l{li}H4|*{-8KS&@i1T|CBf|-Zg<dxo^F<uts>8tp
z$lBh(i5g9LI2B$sn1S{U<~d(xX<Dd=Kg9531P3{JtF|NT>}gX`OX`F91*A*T&AD@V
zpFGF`3QHw9hA%A1Om4i|vdaMF$GwVa3Kt|i;>0<NWn=>2Yq?*+((ZNF-t1J>CC-nW
z?Ey9LlYI?*H8SMnNo?bK78#d(e_sOPBlC@_b8PbFaO!rVL8|+|JY<K$D*rG?GxI>{
z=YwtiZ_wa^?ZLDoO6h=-d@`{m$K43T_acIxs8x{502d;2yoIHoya4wihM9gVW=b(X
z#f2(?3S7F#RjmUj?mj2O7RQF)2aYTEeSveKgj?JyG#uhK2j6J?rpFN(0|J98dXDcG
zBX4VeZyLIJzMQ|E-C)c)bU0m~!<n&cQk>f)_LMhWzG~}IGoL{Vsk0(VZtNspW~eF#
zHVvDaOftKfBxbx;fdf=CU7*+bv+N6R*Sp?!?=Cxi`Jq9nSz22@ZqIJu5e~Fj>I-3Q
zso-Rb<c~=wCht`91HdG0O=D0J^~SMpflU|QlamuS>@sU_!7yotbRkHi7}UWT3k06Q
ze;qm|a%b{g+>=OYH}Z<bq;)LE)0>5V1Dt|zo^$(iU1VG(ng9&aE_s}+q9eyEMru5s
zu_iwq(~*h%dABjiv+{mE9m{!N9Iu)3HX1pLE+B-n79~FDWMS8qA5N+jT?V4QH=YV!
zd14yqKc6G{xLP){4i7xcuUrl~2#6N})-3b%gsI7!S?qIPVq9kCXl*ZH*Ih-dr=^@*
zuiY&0hvY3}695)bXDgINk;$BuSR2uzpK-ExyHf6OE@CNP($mo$c|XQpYNcsjI(B?a
zK)1JMp+J&rU1>=DTMo5{D8J%y_1|HYm<ZLL7*F)Q)8X$I!A&*Mt_;|zF59D;d3g;X
zD|kkE_@|1f(zD+$Qgbn8obt*+kGpk6^sZaEgy2*MAORKWJz`p;<!NjmM}#(Bw^QS&
zB824QHFjuv?)9cpk5cV;%NepwHfs=et*urQwXM|!zWBFcM?+06*BwmvqgNCg(_|^0
z<-;RYdU*Qe4YsT9XOYLc#43IVu3ddS4zS}QSAx(bl(Sx`3x+Fi8~Z$|>3kM3A9!5K
zRo!HaQ2<&;x&)JA21^pF7cdm=f!Fm*rgqPbrvR$wZmOo*C5yT+>-YhJT(?giW8wrR
z%3FTp*1jeCf0GB6fjFaLI)Y#KHng=j(DU`TUJM)|XXhy)k@x@frZw!EML_P$KqwFp
zfY84JEfDg5-!j1H0(_Og0LB=6ty9|CuX28YN4s+;7h?%N8H|v{h9wTU7tf|U-Nk|*
zL(~Q)N^DikbOyDIB75tzV>gmO+U;z~HS152;1a8+J4Wo}aZH_4Vd+mah)Hu649HSe
zNJ;_ai4V#MSS00mR3F%=o@x~Ivy8nbGl4XM-o{4RXz?<kRYPxxph*&PK!l`fVi_Gg
zTr&yogEzMLbYda#Gy%q4i^)>ajLxYzDm6OY-xRQRQXZGqgBn>;OxFvqWfMBMqSp$u
z##f)YW>QFUb)J(AIm>d32e_RjYx#bY0Cr(fLMconrcoW-c=@@sAE+JH+Gg^@=c%+@
z8mbD)JJlA0r)1y3<?WpZ0A*tM4pAYav~3Qeg!<t&W>6gDGt=}<iTju_O81^Q;2pH@
z{`R-RjH<D2#~(*-^@HfU*Vq<4Fb5{QMchppeel%3Tdnxik4z@R&?bVcS<PaKDJxqV
zPJCt~Ug+^fidy~jRtK81BJQ(kJd5Et<*WoZ8n?<5bgVk_Wh|JE0p#~=oCGsHw3X?m
z+RL(y*;TePGO!Mr2Z;_k;dE@HI|w>EeVBJjy&v;lULOZ%@5G9_nZ6#*ZjNxz4jV5w
z+x$OS^ygPJm*LJ2{D~^h@z*)0y1wPr`uP;HBLeXGR?n2w3W6F49F}-Apb2@xt9FD|
zm<rDWYZmRj+GiI5fb0)&)uK(<d?&E^*NxWN$jxo54*w)C`BK^8M5-ui53hOmRZe;}
z5S$c-0)t>TvLEEL>et^%ZVBScUaUGGzZs>*<>iZuP^)~?&NYS@5KAkJ_3ThwEb3DG
zCC78XEf(&~m<CJt%mr5_f`0@*7L<B-zGx|&#E8*{g3g%20bs;z%`5$RvS!T)hLo=x
z!X}zLo5Dwq>*rl8WY_mM>&8Y+raDeb-Kjaz!UJe(_{W;!Q8~h2DiS0Q#*6n4mgzz<
z!LisX<?^o+B9Mu-X6|8k5QSN_-(DDY@I>;6wbp)@%RP-p92gtePdNhxp}P=OQKXhJ
zGM)+s>$74?Jpi|;G%xL(&8$B5E`@Sso1tNDq%Qu=Xd(0>)8|&RnJmWX#y<h@n*<QJ
z7W5T{4OtB`c8xfi`RY;!Vlnq_eTklFt4T)zvq>o}7ro5IBNPN!E7em_>VTG;xTOeI
zXD@6T7+{O<p3pUwj*!~PEp2Youd+(^TU^=HL@kc-V8Am66cIK94yD=k`pRi>lRZ*M
zy4?E{Xj%IDXkw|$+26;~q4ZO!tkLOQ;Z|c;il55F7L;Z;$ch(x?8%e_u2F+%?mY`r
zcjRvL5h=|5U4P;6DwSIY3+$eZP%SyGh2*HUT#NrA;Q@Y^t9ync52WN8pbcpJ-d{?H
z$nT0AG6%%!Ikcx67CZ+H)?~;FzF0SAWR;F<1TwbYCH@9iah;2Gr9=A3PpI12&Mzp~
zencv0M$3r`@pOZlz)-L1wOeU|mT(M_rB$uRbvy=x=V9d*)efx$dRcF9fF!@ez0lkD
zviF;@HjPw&mo(Kot%#I!XP+LY+UOL1Q^^dBo&q4=ErIYjtvg#><&iXJ<j=y}iZxxl
zBpr}<|BGR~V*>2dHkuK|UPHSTZ*(=f2$b;oVFd4ruSV-_aRmRO!o8yX;(62lm-&6x
zg73%uX=}EoxYue0B6FzxI{Ok1|F~#p1=w)r@YbF-w0~<qb`S_WsM`{Vb|&vR^~_ys
z>l`54*CL<rm+#baS5Fq6jJSmB@p*u~R#@T+KiWWEq#$*%3^}@s28!o^TR2zN#LIr{
zUP_KgTd>Eg&2<B3tSVO5^I<p(bKRPKrA&AwuC;F*ZZKvU;sd%TiU@PiMz^Sa{KW%7
zpmhLBRy<60n0B^DX!Lj!`%SUCuo|myKq7#~PZFmFOw~euTnTiffK@y00?%js+pRq0
z>sua?k6LGOE1Q}qO{k)PA`KVOue%=4etYR0@<z4^)*Q2k_<VJy@>3g2-to!XauVL^
z9~D31+$Pfh`tn9pBcw)94*jLMMW|$<rN`|hO0W#8WM*l3XfS3kS$H7zfq&ca!%G9`
zZ6u|IKHUQ^^AqD@q=c1aZE}PF0OBxvxqJ11l*_}E?&(m+JLG?^E(8QVI6p$Y?)(Yf
zogMBz%NKsVWHTx-QQ$jrn$T|3P0wrV-pylXsc}C9b-^|BRx80==v?a}f$c*#XZ^h0
zI(p~%l~tk;P=G9Qr*w6zo=L2}$I#OJS@n)PUY7qM`1s=!^nW|_@dR+9Hb@YV5yr1*
z^}m9T7z2#|EA%)|zqH=v#2M6Yoci4E=3hcS>PCbjpTZub(binWU$hyth)}XELUk>i
zOIS4{{d~>-kwCcYI9qsr-{TM)iGDmyF7x93{$07ozKIhrajcl-Cr>IWbb(zH#wQzj
zB82VIHvn=#FN?bIAAIvCqbiYDz}Bmmp+q^0kZ({M6jezaTW{TPWFH1ksO(=1Yu}~S
zA^>{wTJDdbXIs+h1q$46MRdahI>!9azJqK>_h;?P0m~Z~6Zu+E)O1`XTX>JZ1dZMa
zM<H8Bs_%P)s6$GKNg{e~#G(he$!_Wkn!B~9#LY6Nkv?)}<)-j&EPvo^0%C)%vnEDJ
zt<Q+sAys9INuGVEC>Hmik*0iD{oOkT1L>3Gbvql3ecwTuTpWYj$Do`@K=l!HuS|V4
z(~=1Fp19hH7=>+8wg_Jwl5sO+xi|cX$NB7SPU+OuxljFx3)-;tcfOx1z=`>P4<#-u
zduIq?DUjZ3taP~u-J?>$1h9Q;PVL*TW0H0#(=0yc*xkF5y>-<tHsap%T&{C%8$a;f
znxE1w)7AG2q}Y|+nHl>7S()hW>_2N@AXKro`cX0q+`awM&u(}7drxODHQR01+oL>V
z1{+_K7%jN*9hp^q=WLtpBJ#h(1;&>l3Q{C;WV((p2C%rEcPw9bLhMVEEgQOEy5e-;
z^s19z#TEcQK0Lq>kPO{6KE1sk@O8!){mlIl7hyB5G=^}9NAD8t@^=x0BpH>FCXSX#
zP=&$K$N2&pQgfHP#<+qc5sf)HzQ;a$7!_kmEg1AgjT5ry4vpL9RVQvbg?FP4CnPYa
z^w+;lkeD2SQ-h1r01l8Yb}0@A_VKO49JQ>nF(lR;ZGI{qxe<Z#<>88E<PAN&Vxz8H
zH?MnFikr)XxhSy=WZI}c9Eg@uDq=UE2a@;{{Xw!pfjqitw(a>Ny`)86US)6QqM-7G
z<NGj7rTKt>5Z+$n*|m3ovjfA5;Z9>G7@<0C*re^jlLeY#3}~bFU-Fc^2OF#@o+t{D
z^RJC<_xI+GD)v*iLt_|PqB%KQeIXRj`aN<)iZC)u`9a60b2>%H^lR4XTRCH1Tb!MK
z!ayAzukkN2FPsd7Vqbbu%Q6KKTE0GHPHa=O@&(0usGOn~iiGAiwtIY{p|q()Q|YZI
znh8?IBNha1CV;BQvIS@G->Gz2pzQK**Xl}XMIyVhcWD((4u?a9`x@c9Qr+M)@g7+=
zIDc&gb!WWwvW|{F#uupVYE(?fQ$~D<u{-D5g=Eo`4K=mcug>kiR$I)tirt^H2{<Of
z2M%4}Ek*)9dARG@mb>c^R9^oM)1~&DGgo||afvW>lL0uQSUN|mDU>{8xDw>JK>Qb)
zR$J^AaUD;eN4CNV&*YmuOIg*8qb0Xy+IUP~17UhSe=NHxJ)D-z&KA@P<eRFSGd6*I
ziZs<pu5so*yw#A7tARmMuYoN2Ss*g1QL0XC@1h7_sZR&tnqY{}DVZp&r%PB*VRCw6
z)J|D6rvOU2;k7k($hauCy_c2h(#myo;MXc1ZE)A!erwii(QIW0HX1G>adCVsK=Iqu
zk@%{(!@pR6s4>f~LYbA#Dx+U~;MH7Je@jy0wE(~g&Na-G0J834N6l+mKc26hH<=0n
zLMazoi9gkJEAxt89CsyZY7PatuLe-}oadpk)&RWCKKRY5hgwy|d@WC{XS0{W$w@d?
zQ^yEg0c1+FB?ueVjtRemS{ZRhW=5wolq5{Qg?awmI`h0K(BPu+HR^m@8?FLw;t$!2
z$7S%K9O^4M_|LpG_R1JmGqo!^HwepY1umkIxk#TSK8+`8K=xLV4y)$(Er%sV&9_Gd
z762w%kSf|MDo{oTB@>i*SP(_yjnT6my+HgQj>d|rCe@9N*8{+Z{k`iVI;1pI1<3~&
za#cJ^uDH}Z&bhMvN3=UWe#NgH-f#XWDV15{hw6;mSbazS5BjUVoQoum4Rym;-W~as
zobZD{{>Qm|P5OZ!5~x5sD-@uO1sdS%Ox90bnO+tQAL27X9T$ZjqBY}gu27^#SS?f~
zT1~It-F4w|<@BVV>xJVDzE7YVp$P|TUK8WPl&iG`yaNSRop`Yj;hRJ7BL0_@j3__H
zFr@c$Gfik1WBiDNgi*M2m#217m$*%)WUoY;Gm8aa<kJ(8l@)6Yla1+F)BvfO0q7S(
ztdnfnmy)`YKO4w3+3F|VrvF4)UtFDj>AooOS{U}ca!JgeEM7!*`$CIP2v#s`GE%tX
zs2kNagw<%2Qv@&=Z?m(#b0aBWR2@~vA=Ij^t-7I4PAis^kf>m{g&}tfuQpq>pFGy?
z_{AA)iO%MQH<(24WH2)U=79Lu!0@797s)KlJ3g6D<()q{-AJ_1BD_F5XVH1EiW2Hy
z8ee1nz)xY+$v}JC8_c@90Y2Nt(A|@!?a+|;9-Lr-{HKT{z$fCCpki7q@Q%&*GxUdO
zLao&ac97Xr(&6*m<M%Dkiyx<T0VUhQcqDCljM$ASxsz4B4!*wM0Gc2b>+aSFncXLL
zxJ-7v8T~I{cfWi)b^aW7DMup0mHYa8en`|`deQgC1`0|Y5rth3x#-72;L_Q266^ox
zD_{M`tnNT`gM969IDK_|ZjgVkc-UFte{Ej;v)GaKbJgl=ThM2-3I|OzJpkSlb1x4?
zRBjytPn1TAh2GMHS<}+=oTi@f?lNn>Kl#r9>@u`v8jtgV+mf@043=zuBT5>AMX=BT
zBzirtP!=qC53SQ*B#aHcmU-c=>|>;IYgAvH9*E9Ol*AxRr42(VC8J5Cm`!Q{AQyem
zfg@GMZDS!cX_~-nrI})q4-*@(SdR3oQVu*+HB}7}0m%Uu>Mt7}5<W4QeAOb=Gc7Kx
zN;3o+3E}8<FKce1r*a=8TS>Sxpe-6X%P}rwohZZo?QG>x9fWV4K-}(0QG-;h6Rp-k
zpLHI!1Jgn^Q(k0XIUxAjD5QD>EOBi&s0eFAGF7!uHj&R_0IP2>GEU(=m3mZeID6bt
zxWkwAdc8RKN?G~4a#tFz2M=~U<q0CC3CIsTFT{_igxQak&|P?gCzX${fR;=6GJ?IH
z>9t|H2cKz#s*{yuGz2&fx?ZCN(P#CBHxzpn#gS^1(C{)ER;&7&u%(Ou-vEZ6N<qu4
ztHZQJv-g8Mspil>!J@#U*$j2DDrE6jeh@Kr&*u8C2z0)F%h>qz+c~fk$XR>KeDlwD
z*p$<(afn!U5qN(0fl7e>#pjtSXHT6={(uPnX4u!ukD=Is-%>&Tcoa*$PMFXpt|Wl$
zCAjens`R@$ZGVklGyhD0(u~xK;!MC?<n4b1s~TVbW6%Mx8iM`8!`;{5o$4!C#RWFl
zpa3e=R_#_LP<#&6WyirR6BA+rb1jlcxcDI7wm2;As89wX2!`R~TUXbMm{7ldDw+vc
zw0xGq$qllOU%!>HbykW32yeX`{)lY}$$cf*Byt`4L)$E`vUwb740;Ga=#_TU%(xlQ
zPKY}WDTprD4Msthl1nk1QUKJpd-*Ms7@$1xh-ak&6U)-r60m62>;W9J(!`>#i?J#6
z-7QGv_NLN?NVeWL@lTE`((>~|*0035KllYUVJ{P;d{8RsBwqp_8Fc==OjW{z2Uv8c
ztsw)z)=&roJ6N&J8l<D7Pig7GTG7ZXsMmlf!<rXn!WcuTPK4*7$7fgGHyyV*2H?x2
zI6bh-CcD538^{!^$*_>=M?eOM7i8V7*exH_n%})v2~fPv?yGoQzx9uz0NpRQp!oYi
zu$8B8y^O<3w$?!YPZ{SP4b>I~aQ2FdVa8+7+>EL2NJEh!kA#s&d5;jfx?H7HuDpiv
zm>GHZ^4JtbrBb>QZiwY3Z!XhlTGB)1mb7GrbXh80-E$6$nKd(ioc(>@Z-2AT?7jBd
z=j`v>jXTKk{`rqzwb(gY7423tDg9*I2%2={U$NC2j^DqNPcP_gXn*U{H{jr9E4+1E
zzBs<ZX=RL#4twJtS@zrwUrLfQ-iA=~N(^2Lo`oLv|EnU3c|Lag^c;JbZSU8xZJ(}s
z3|U~xJCyLgRKME#eA|R}S=(IS(>WaPdbwPFx_@r-M&>$Gobk}lp2y$M6qV<EYuz4z
z({;(-mAfNI<+7|<VDoF^=BBYta`;`NDZLY^KH=*O$%HE%4~~R{a|?XyYTC#B23r{_
zz;bNrjl+i9-4wH}VfYP0GH>u>g8cRw>3#P$@;TPowPU_FV{e6|X-vvqchyVR_@_@>
zb*<g(<wWx;-AC@geMC7PH+U!7f-hGPs`bUeWJvAWb+h#ke#@~FmOQ^$Go|{~_&+MU
zo0o4`z>;fp&FvXgYT~w#g#7t?$2=Y$x;Z<&lH7IDuT3f3!ews1!f|TPHQ(A(^-gau
z@jDMYjT;jGetN8i+Y#1~>zy}WmF6eSd|Whew8o5i3iLSothtb{*2{b?TR9l2qNw?8
zqM?xdC_uAAf9*{9q1g|Yrka&Yt8+qoK6nfo1PAOdzcSjYxTf<8_sOW2cT(i71KE8f
z%PyG#OSe^JKRC)f_VAy=l0q$HlPr1fl%I#{_QOFlC+o(U@5r^T@$E6^LS#nrx^~JQ
zBr4ky&h*Dxyl|Lpnb7=qNZ)AM@w@-$2qN`h?#S5#FNx3j?Bv!cL2hczF~u7m4~>o5
z^m_&VE)Pcp$vxR79oz&)-Q1H;&831N?VnUnuPrKb&Q!0Wt5ZI<jyFd9=bdVl$#2+p
zGjB?f_pP|U<&%17S^dyh@M?Ff{(>7H1{2TCDA`O+-;+^zahA^zT&=7)LBDTt)NPYM
z7&A7@xqut+P*!7BzEeEI@nr0N#+p-cP*S)!c}~OmN1#o67AtH=LVpv}`Q?Rd+o5@r
ztA(ZLZj3Zgm0H-3kvRSYIc;G1b6*2iyK5oGq3BU04j@>jkW#(oB1nPNiA0J-#<du%
zy$*p5;cU1P28ty+ih*CLC@6zvYNLMPst7U|rXfl*xJsJ{SrIgFS{D;tA{F2$A`&+*
ziq@cF3s$s<!o#PLG;mvgQM8e+hk=Ra@RhCt?2MuTudSE?6-}e*;KzbkyqN&&qK!bT
zA!aS!Oh#Y=+`}RPEBdmEMF+}8n0VO$kF)>>d2uVCkAb41=$*tFFCrSSIff=Z1xu35
zA(y@q>c#2<KU2)er7J)pn*i^|lEAz*WU%d*+)>#i@R@<A*kIBIgJ;-ukg*dhR#+-w
z^-|(UpvrzpH5Nw)qq{Lt!A^e3Rb)H~Ogb*9wd_|TEyBUkcrsYwjHww3TfvcqVwQs<
zY)qhmW>?HYNwfw`x5c6wJngs|_OWoVGm#8FE~vFQW+2EN3OP=&fJ=b291=jztr2oK
zAeaf6+;9-&fm|G*JdX|{_8^`Z(ArHFrt@e(#dA@_V@~l&WYB@C93U%+20FZuqB~}p
zM=ZVGFy{nnA;9PpB;dXm5#zv{y_gHvWGgW21Eo_I{=gfa%3^)N_eD%>(Cvp@tl=eZ
zS<KDj6cUKohpD!tnt}DdAg*-KtTkAcila!Rw25}E)ULoK7#;j5ES~BiN}mdbQ@>Kt
zoDXObzTjCb*j<#BdLFU_qr=}ejSNgfF;!-oHes6>JAfHvu#jHZ!Xi;5<99`Q?(di%
zBq|SnN7^9~w<pR<2_u$Zv>nOmWMCeHsk+mtSY7dm9MQ^mV;8|S*wldjkXW3FC@W<e
zhroKUD?<tMDz;NB1~zg~aCvH=;3YP9MEO0*2u^`n0V<H6v2eHIuhK+e+Q}st?N7;v
zFHv}BHU@_s!6Oe}1U=EYRdNY0TG2Omu_6f;XW}Rl>o-wWsx}W9VjAdjPR-p(2HC$t
P^1_jCB@(Cu3Q_5QO+&p+
diff --git a/src/vendormodules/test/tomlish-1.1.3.tm b/src/vendormodules/test/tomlish-1.1.3.tm
new file mode 100644
index 0000000000000000000000000000000000000000..08ec371d475fe9b50283a46858d612265cc0a0ff
GIT binary patch
literal 41457
zcmce;1z1$;`UgsPBOMMU-QC?tgLDs}<j^1>DO~~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?<qS|jyR;&RM$+C53~@Afv-1GkdxP8^q1U-Of!u7(-9TV3H;B2V8`ug&
z<KSfF>}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#G<UPK1^J!{)6ogyU~X^c0|pt|Ia)h`TrDAX&Thtj
z(3PPl0Dt-ZLIEluFa!dKlKKM1nN-}|EzaL&1L-)LTL2OT1Z)Kc<mX`L2!>K~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(}i<GiT=?Xzh43UZ4a0QkQUD6<n>1$p{M<skw3qC
zVF!Pd+3#0C*|)becLkfCM`BY~u#E%Q5eQC(&`9TK1B6I>C(j>l|I>v5S28yK4e?KU
z=g|}zOkJTY{7%o!(q2f&%>kM>T;2Xa>bv0WElnMuWI(j%Kra*iJ?ul5f`T}^<PtY$
z5#$2>cZ$EmhhF`QrvM2D2>fSGd9nOo<wX1IO2%iN_0vcG^67ta7-$&0gxVfr?q~y~
zz02s&L$~oIKm5xYAi$!GLBcfdK+u8)9WVqa44^u;0zt|DrZXth(3b_^7q|ZS>F;*)
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<K^1liIO6h{f-w1s_|7`KgVE^C2LHmvHndZ(ym!*?~
z1CZujL1(@Rt<r!(^lUw25KtgdQ~#a$(wIYR+@Wy;C|{xVq@^v?ZUK990$BiA5U7>_
zABTQ?Ru_M-Z-s=epXEldo8@nypxn}c&7r1yQ5CofotMbpuR6o!3>b_X^nIum{Fw+)
zqyqVvi-U`sl|xVn^ed5zE6<bk8L>YTv2t>xcZ1p$i2hP7LJt(?U`LP}P!&Q$<xfPe
zKmqCM1e8?Yv4a5PvIm>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}<u-#PKWGb|_$pv-c0wsQl6B-Ir!EbEei{&4aOQG-080RU(dAa3qJTLf*2
z9Gw8wIa{5{g!Q5_J6Gr}M<-99E&0WEp(g6&?gny$c%KQ*?a$JIB0KY(i%#W_+JT+~
zebM|TuOG!S=!bOv$&Z0x2W{rS4p4qvfs71Y+wDU2<{(dq6QE-ocd)A~h`}7<W@inw
zeIOtxnnSZF)G>jM1<?E@+XZaK)g25H|Fc=0!v=smy92cV^*_M>sndUyz<)#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<mL)u1?G=Ht^+<hw-ca}0cvV!W#IZ}Mf~n&Pz!(#R(=G_
ze{>+|_1`1!U+VK8O#PSP{;WW8wE<E8v{LA}^#_?Br2!zebMC&|C-D2b83Xwe(D}J{
zK??<Q4<PcM4F}KXvwxZLeUC%me_u544gd_mXQ>sffx_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<JA
zz{tv$m6MH=jho%o9cWEl*)4$i3LCT$gopV_1&$-o;2Y+i=vxFBm`oxV7*QC+f2IQU
zLtyUaZVAkC!R){McSij56cz?%L(kA@itmblN<equqe2*xcoCoH(sf9N6-Hriq&c63
zNk-KSgi`B7LK4vqH-+Vs95ib2n~1U|=0OoM8AnSralRzVpWdq6A;?6tL#&q(OlUGu
ztJYquXO>`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?<AUa9Pm%{w(~OqUUo(mAh6J`}mVhlcuDs)`jXb-S#VC
zj(BmpR6=n?g)_MCqH`3F@v-@a;Mk||(iM|mE<2Bl>>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??;}@~*acb<TapJwE;b%k1cg
z)@>dJAz9QMs$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=<k>^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@k<E*otrDFG0av326+@#Ynn~1>bfxh1Gp``?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<gpzq(!JJpj-XHWA+2VNrLa^>=1fbt{l0EB
z@N<AOd52}RhP;Aou5uLo=Iw{P4=W~cbZM;%UipcSf;1ilr=kl4`xNv^Mj?laYB}Bd
zyrL`Y|9oPMdn)XqKr=7@L6PCwXOUQ3y)YjlSrH9;F><(PLpbj-W$F<Ww7v3uX(;t0
zZ<s~OL?(v}GQc5Y$oi$+>us=@$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-7cjXLe4as<adzTA2<Z=Y=BN)T+Do3hpwZ^gD9`EL&R
z%Y=8LVorV-vm{Eg!r-+B4fU2r4BTm@-rl<-odBVJ7mU*wnrvx*RH-`)&lSLubi4cc
zjcDM9Q&57q2-nvfv+SDzLxYtB>9zr{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=M<f*dtIkMcM#i(rnQJ_pO(G$7lw}c
zhr4N{ehpgY;SEHur{cSL7KoF{ZyD;`OL3NCLm@B;>F#U--~5DI;(T377@Yg6H^Vy1
zRLdh+n)JyV?okxxdA*Xw{yup+*H$B{m<PL}vf#2cSw-Vd+QjW%#d<Pii{%bFdKEZc
zZ>`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~!Tq<z_?-THBs
zgu-xpJ;^6bSOE;xN3zmOlK7IGuUIg-zQrrklr_4?72#x-RZp4Bn!z?6<!7d^wQh(s
z;J>0hecu>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^Dj0<WMxetBO*)cmfSiC=ebr-THUu|Way<uJc
z=Ib8PmgJ2_$bhX1q8l7-^&)R$783y{SNArdGSOSXgTt`2TfVSw9T^_MjYy2;sbd%y
z&8n(8KJyEQ|3vt>kUJ@783|=q5ecn&>i|cIoAZH1KSPZR+QSpBoJO9UxW;T@wOmF5
zHi*5jaPNl5llP-)1XeFkGLn5E(hnKYcO~h-Vf1<ute#Zx4eCe=<)!cX+O7p1C9N3P
ztZJ$+soyrIdhJJ<nRcAwQn4S#F45c|H+{W|n8jgH*6(dr0qCVV%fidCX0HYvW#x23
z#!5|rZ<vVYTB<1zWqg};ECyk-X6}nE2B+xEd@*#mDs;MVY>yvxW1?XOW#wqkf{mKI
zYEzH%&h%5tqV^qK1BxbD>5cU{Y3)M+*j&y<M-*a4=b|nI1$>MvEOH+jq?NMcDYz+M
z;$-)HZoYaL^XVGlNlt6g<K*$1tcNk~mdj;f8zxRSF%{i?bzYEac`zFUj$mp}u;>fk
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|k<yq-5GnDlZEoJk9`ct3PM1sx{D3T>bRlTZb}CflH0
z5^We(j0ffBt>HJ{^eQAvSSS0g<EIOz`dex)*L{-6qPp&vU%B#W?`Q-;kQ}S7Lni}E
zP*X5>p;vOun$Q8Bx%a@XqS5CF*ElV`RXQNUBrVfl$QQ<q@~$N%>==fDI8*9u`;`7#
zoSihb*j?wn+mu13Jj!oA)iB$d7e$Usx1(@{f;X|UVyQljyksDhP2%8SGV&3C5&6Q!
zw4$$V{P|Ok2alc77%T1kBU<eE*{H6}ic;eb{R(xS-2_;^gHL8`Sm@|Pm%*Em4$!!Q
z)2J^tMXAZuY}4Z7J2esuC2P&&YCG>wG7k7OBH^;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<hk@aPLH-ZT0Fcw{+@PZf
zQwMioi<mvok6&~F00~&Q4gD$ADG40ExTFB$P!XLioE5D+k(%zCxl%=>%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$UDfJq<jV
z%_Mp1BQElie5ot&BZ34r8H007g2Y%v8I}VpWV-}2?t-!$<FZpK>wDE>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-<cw?F{V>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;BBP<Z>SR4gke?d90YgDqt%C%&;%|H4z
z$D*NIJB3mycRcd5Sk!0L#d@8E)9fDitsM?uj-fU3<=SZ?9wx-<IymhEt5V2^8FO@N
zV|1-=M_$_`NjNQo^1;SNbDi7e_tt{$;6=5mc?btwYQA@#1{x4P<qld0T4rIi|FVX3
zb#ZqBZjk~vIWP6wDc7T>IB>!?1CQ@gArPYZPJFeVm<r=_OU;kTPTIh`;+qzp>>!)y
zi63&}D_=<wK>IB#eni@>vXrESv}FOAR)6=UE(#hy;tiB*ct}r4u)>0)^NZ-BaJE8G
zQQ)pJ(0_D>;dz9S(QibOsa1v@#1HOA*GgkWw6mv^Ls}psj`7K6P<t)%MD|<!x8iMW
z=N3mi9#XV5sRzMnJG}SHTj7RNsSCdm4%Iio8ZzD~P_k1Vs3s8YzmjzYd6w+UtweU(
z=qH_J_r05M-M?|;&XW&3U(7Tu2sfp_-t=`BwxAgqTpO8uvHpm%uXdXk1uwY}{S?tM
z(QAzjFWJj|`*TN%<p!PL1TLR9o#DW4o;Tc^O_ch;O4E;r$YK*2MEdqu?ngDk4q!Zu
zLY;Pf28$LGKtr@cE9suMcT4LqsCQ;}xv3=%p(?u3DIi7NVON3ekw+FK7<7BzO*}mS
z#&-`V>|RscJtwn`<LUs%^kBn^ovjycUnz+NMN@CLWDZ^f;VoyVDtx7I%-8lSDaI1b
zp+hOu@S2j#?uBWFR3l}8i_GG_Jj}W?ooViJje$+!I6y(~knx>(`}`HWP5&r_h-X(|
z<uXXS>$k3!-*ViFe$eiL><qgEr$m(W&B?`I+h`AoI9DQgLwL@4>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<f~E|H#(pD!|P9L-wp3|
zWntWiD@u3&R1de3WTB!-<>{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&+bN<ImGGTQ`bi8(7Bv!SI*zGiDm`+#k2*9f&8tuto|&6e5?7i|5Z$S{;V=5
z))&nu)+Y%0yZ2%d)5BnkvcIhEJhz9t=6TpM2#de&FK~j!lKYr6Ra~yC64fFDJcw>G
zb-hTkR_N`Mq$iD<CMhT)E{8+Tnzk5I0sU0G@Ts{sV~Y=z#~6h8-ohqT%kyuZYV&JT
z#KE)|Epk~Kt@OQ4R2Hd8F>8UfEw+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<sz2Vf4fPFONz;v*Hxd_yp_-e@u6<WiGB+5$I4i^Y
zYJN=hEqr)?DIuxpKKEofv+Wv@37jGoL6BPta+J)zP$bUhhz-HSqsg&H!K?_Al^V1f
z&!-lKR3uVfRhfE4!DMP=IU3}%MtCi;9L>>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}8lnPw0<IJHgXGRO+QpfX~3)6_7jEDT1)^|2639M5&}PWpb>Z6c#j2{v4${qL=3
zN>g8DVrnaO#fvjEY>rK3+cDPcQy|l;r&Z6xBr{h>BrC3F#0Q(!Fx5Ydi@^|e!?7bB
zx|#9u0M7%lG<jRR#Y>?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%sZ<PgH6e$3||0>M9UZ$_Nfs@5UcfkdEE`
zSoZD{Z=N}g$!S7as++OD{%KOFxXt?Pyq$^h!LzHg-&8E33h!B$OY5m}ehasHqcbZZ
zd?H?eY#d4YW<tHCVCsG6RQb-EP8x~E@@(8gG24piVp41-5yWeYu?JnW`HV=-x2QfB
zcH7$&_TQ+9ET|YDeKW!!4Oii@wSKCpd!R`2Mc+dN-lQfzYjVxGI5a3@1Dio0Tl+=u
zT`aX_^ggs@8=Xzz>m7{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=<v^#-5dfj_cnF1zDU2WY|wi(r>D^T%lv%kB{QRLg-*C`k!}&pNSF{>vP8dv
zd^VZ_3G?XM7K9N5Ba<K~lYl6bK<6PVha-CpN0t!nDOzQ-QM1vdx)MH;N&of$`F(1j
zuABu9ng2AK{1I7y#@NenT}?SJU;@O96GYXzfLe3!IP%6|JYD1pQ3Z###p4h?2^O6&
zWr#zmkO!Dd_S;?>1p`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{Y<Z8a?R4lDiMiV`io@ohxfwUWFh;1>P)wTwf}5|R^^L5TUV
zhHw-^Z?5~Q&jVE<NWJ<HuWgu>1Rn>B8Y-?#4ZIJ3ti2`9amP}u(f<0Xfa<nU!|Oq<
zfDgo^&DB?*=0E7CgHuFR^jJ2<$mM6F?ea9ZcjTw=jd1_qv4wwVuc7v}i2HEEuw3sN
zY}@{#h&28<$7_JxHi6^%e`=`zOGU6cLF{bo9L)j4IqS0lo!mOpiNr})6qgrg!NJW&
zHxxJ2BsNy#pu5$6*JZ326_~D_w$cmQDM_xZ`)xJ|M>J<Hkodk-W>I3%P@`Y`Mm@_o
zl+KjRW*<#9@@ej2Y2%}mw>)7vY?Y=dddYg@ikT7SyqeF6BUq(&Cn=?<i1VLw&nMs(
z*$74&UHJ^L)|cBq6gSdf%2L#N0*U<SdtBP;BN0R5;gmTwJ{_f9@g;)|mQ_C<6$>->
zluv`qp`o)Wm@s?YZFG>j|FfAf6K<D=JeJMP285V+jOR#UOH@=r;kDB1hZznSL8p)g
zW}*`x(%4`TgHN@eM>7P%(5`;;bzm%Ti;zf^3YuPxHLvLjwW<%(8BgJVytIl?C!VV6
z828!j#t6&2iiD6vm~g}<^3Ng!0dSC{BjM;&z?VM*ha7PH<Gs_r*9&yhi!1Q_kS)|l
zyxe4CE3rB`Fl6>_hmH+yAxGbay+y?D9wDm`v=OxLOHS~3D&5`Rb0PY3HVLm}XO$J3
zr&(y21$kX`V%u;YA>0%BAemxY6fcqjJD5A4i*d<Vo##}YmEB+XQ_oq@UVknUh=y`=
zMDS|uX!^QJuM-N*%UF+X+rH)Fg)&=XM$)!EPw>zlchKuhqv1whhq32V?oLEjbnR76
zVt23p%6?5;lUOFe_E+Fg`#)p<hhhGZgVHzTClB9a6Cc36VRKx^i;72>Lj1fZz@%BX
zv-;_vGh{~^|7J+Iw_@66I~qZ^*9@N0p;U4rY6&?i9%GK*xThCMj|<El=P?pyR%aMB
z=P0nUBd#-FB9m2y1R?^jT^_cf{rz<r`MPX)6)aDWij{jOh&O7=c*xrN>gb$!$T|+x
z25mQd9J-&MuAi93C&TQt9=-Dv|5X-C2d(pbfDE8!@IS;#3t&?Tbno%cSovhQv_?ls
zMM-ylzIa%tLPuSR6}GbDWnS7d44fvoXMN8H5UXOM179B7#}_4VD%5j5C4LTjDSklh
zRBdwuEC2x01djh9e*6ONhng<p$4{I~^Gn~625z;dL6M@A!#x`SknTiB2c{j{hercQ
zivgrB5icR_!#GuVe;)@H5kLuqBp8i<pK>g`-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)Kpo<lF;5%D21_y$
zf)|mkHP)isWW0sTLUOgUw|#2-0ft?&Zl%cd-umFIey%z!<`s7xo3;4lvAe~pN85R$
zH*(-v0wkYyu;e90Mtu7wW76x2S&%8xbq9UR3?Yxc;$05nCm}Vs6&}6G_V9a!s9r%C
zei93|*P|>Z0t?>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(<QnIcc!Hd^^ZJ&<Q
z398t#0&~jNR6bT$`4ElS-N*>pSHUN+J&1}-wx+uFjP&hv+@ib4_~M7)Yb!2DYnbq!
zq%4Xx5)SLU@Ir{X<!0@#)^Tk^VsA@ynZ?NPElSwgC1EjIag^m(#sNZ~lgfj0a;XaR
zHVf)opWvun)$r(9r9ZWF&baoZduN)p#2$NKHb`=#G*oaRp_*HPoOkYF!I<p(<{0&y
zBY8i@s?{$Z`fy~P-p;r-^K5s=$=tDDz*F9f%MDg-o=p{a_uS-`j#lJ+e1zrxAm*(h
zyKTguVyC9r)}z@XcnlASJsvou|GjyGz04h)?SVTd-(ws&zT;*W2L>?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@{tuEy<Z^Pse^PIy5+hz`e^#Rk`K
z-Nb|6k6Y*~@lA>A9U3I*zIG_}<V7X3_b^u?W77VVR2Hf+;xFB)(C@CVByJnrQ3pBw
zmd-$?XqX-CAWC4EWuY);CC<ZA$3xwgj3qVE>#OiW)Ynj7e?}2K!0EVkhapJmFwml$
zw}7(co&~pA2qO_MLG%NQK+2ZnH+?zW5B3<XO1;CAcNoTUI+Mhcq$~p-JZrkPONjq|
zB1m9#gRiqs*p7kUVx9k8il&}m)-2gN$aIf_S69<XqVJ9)an3=<_A|a0^lT`^)q$;Z
zXokmFO2HWhRZEXP>VCM1_`IJBC-<!qx4p3@vy)u>M8u>d9M0+P&{YzjG}2g=O+8FA
zjac0Z6gbMX)FVOhqe3fjY^BM%#W?R<?Q#Yrq1jga$de^Ou-5s)4vv`-;Z8Tzg5a-C
z?Y-G7edSpkpQV&9x?WuRoFb^eV}2%;VY5!o;K`ah^J~r_1>1X+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~X<C
zM(YX6&K=Nr78cGZZx+^r6CXc8k;2<FFe1-xW1(?H%%T(>wqeYs`Xg>l>G#ijI`AD1
zgQnH#ss*f)UVf9FDj|t68LB#zPe)fxe%REgGN0?=<m~H6i3QV9W5(qvca+!Q2|=01
zItZj)LG9A;U=wJIep`}x^WoUIFvZUE5c&B9y^r#*IY`X~Zpw@E)0%r}Pd}dz;EMqJ
zfdYq(baW3XSF0zfzqsD~f~b02DKBKeeNDb8w=j|9fr8o+H^wV`R+r(|KBT&H%dUPK
z&xmxy#(aqVLiCh5;zpd(Bn3nb8BtMP$6Lztm8m7_2#SO_ichzxkH&(`^-IwYng-HJ
zYUysqY<RvP4)#wmR)mi_NsfSPd3NLBbZ)E8D($*_hApDEd$@h1DX%iw>xGI>@^WQM
zqM_h`KJAo%)VEHjlW}4@bGWE2N&MNf0n+^4j{Ynf`k!64BhZCL@CtI{Uv?S<SW&&N
zvBMIOnLwUS7>btrD0E00O@9~65YdGBvEun!VlP4AZEb2VQ(D|x{$<4rbH%8Lz2Zm)
zn|zOaLkkQblv$ZibyTM*<cjc&2qt=x8}B>ZqaUW^d4A)jF?}nEew4ga$^K)6*e@Ww
z=^`^}TVes9*3^N<a9~uS8n<sAdH4PPM}{OG_dsLFsQmh>R|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<nt&^RdtCYowDGnR>{~)WFh0U*rCMLT`SJi_bT+uQEq9J9%M0u3yMs=x!o%d
z2e+L_KQrAF8~Dl@lDhd?Fh<yqnKKM##j?J#b^JqZyC>Ogm1{(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)<Shij4o>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(CJ<Yov-OooDS|_ovLiiQT(cO
zJl0jKy!csndy8^}LNaJZku;BQl$!y4-`j}ShcV)-T5TrNKGrj3gT80Eo}K<V#dZ6#
zGY7A`K>p_Y2~T#G^T-PKww~rXIN**)Gql^6lLual*^?33cWmDxY<xdX!(&9#MS5Z}
z?Dw&<`S`Pe?H45vwCmV>3oow<O!|kQ&@XJ3Vl01lL@iTZkV5WWuaPAEKt|8R@u*H>
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&u<!MGRQH0T
zo?P8Sy6Ye~e;hs?UV48wMj_r_c5@#+d1@%wwl4VnlU5d;GB?Z9XFdXY<Gxi2f~os2
z<k)3n0s^FnCVc~DqjOI$b)jdy4y*l66wvE*0muJPqgVsa*0}wgxSrK06w%69T_9kp
zl-8-4f=kGk8G`sC13sTXgIQMnDT~jsg~#TAS9AM;Amz8QHJ8UbYY3>iQZz4vSrcj4
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=<dEwn&aWj!sEM353YWB>a<hb
z2rflHMUr~m4i~lfoZldu&sM>`cs={}?2&Hmq!4{NJG|>XA`R3HtmR0jN9ALF<wGfP
ziO3k_k+q*b(x&3&hPI{*ec>&5@X#2GC&yK+S7Dyfu<8^M;C;1`F;Md4Qq$#t$)Z1x
zzw9pzFs%z5691lgTXTrj+3Zkj4w$}Z-hs>Cj(&#cONVHPnE(7(Gc@T~<O^PCV)V;q
z`_TF0ciN#N^P|+EkP2HRF?F~+;%qWhm`j#ODi~nE*q0mB3Uq=&z%)kT-?t@DV5YzI
zChpqTozggPT6UNVK2#7@=}ek1(HShoOXq6~y7?AqULo0HdlM96kKf<6NtXI8(txeq
zOKhgudm*j1A9-?B_0^!zq*y>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{<OUnHuf=R>}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^<D<6SsINIU;YNuR
zRocun%NA-p)T-g*!?K`J?TB|DE>GuMV+o9Aqtu9;?{B~9<!IMqa@(@C9P0%}qkodS
zuTg0FhLA9)FEa0DItB76uIcWzCJjk>Qs4K6!XB9A^4xE5o>DEPx!*dpBOLUCPbiIZ
zQbEu$$-!pU-ppYm>KNt95>l=<s}^RX(#?Z>%~DCp>^(61Py`<-W$wtKqE9u7jrWK)
zBUJ-`r<x^IgjcGbr_8WpI7{QT#OCR0gxqV%H5?xJMEUC#N<w}L%*jj3ii^vF&!%$5
zkNDJ`vOT`W-S6g*h*dWy2TS#TrgRm)EAHa)=3Tx9%&;$+=Sw~pbLG8u%f?Z>dPJ{|
z8_P2VbT6ylMf)Kpep=l*{EGf6YxUCyxleR+#zK(B=o7eK!&jP7GeQ^ODA|CcX#D%O
z@;68M5yCF!tM1yBj==t`Y52vfWutSlE(x{Dfk<*;7>JryMZ#Ae<EZ1Y;-)AB=H;wy
z9>pf*3OH2jQEkq&`0mA$Y$Rj54X5V>yVnHldjxnVyb4~mMl1bl6_Ybpvwel-vHwRa
zby`a^rPMSmNfIU-@;DQ~{PUQEZffo9fhaN|X^;#g8)bdCRz$q<NmmjC#77(Tt3nVZ
z5B9zLL~$_8Z0vC1V&3YUnA7q54=n`4eK>?*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%U<T2sE(iwO~&{7ftes=>l!GrCDa
zRylg*&k!O!EnLvXJamQ(Ysg}Rx?fNBcz=BM2s0J=+o)ZxE_+EGZX3?Q0V>%-c0Nh!
zc5<kA8|wp4InSz_YDX>=#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!JZ<gq7l
zB02Yp*#6+5<gS*A9d`(xXW#Hpxkadl?b_-)S8#T|!(xxQ9T}WCvf7+50tjURCORQU
zA_qb0;S|R4X!G>pZS!1;Lmb~Ufk#emDMm}Q9SNTv_at?L9>zTeS6PT&51+BA5lbe9
z#CB6&g<EYirrnt$SjD4g;$BtVi4D_mqtf2GZPX(<o#`<1)Zo5uL-0=N&6ZXlKmTE}
zpF*iXKUKJgG|mOR0R+edM(p1U#oqezjBWw$Qia1}$fOU8rS)M4Si%5UN)}k@U)G%t
zcCMDD&_`m=7IV-%+eO=gynPkvU_@$u(xmp_P78172<s}<u=LITiAOyatbNRVsRM1B
z3WID{f?|emw|MXHkdO;41qOt4o%GTuOvOG@dA?kIz*01fFLFmAdzyJIo1QZhyagur
z8M6R+<-AA{eLG;J$2B*Rm&0sC;Ofyx#i%INL((I4%iW%7!e2XVu0*OgnoAu?N`5X_
z>w}wY{So&2Ix`dzDjSPu54{*~QBRz(H_0vAbx3{=^VmQlW#_=kklMz2?v1rA5|aTI
zc~Hqd5$95j;o*Zqq~H-PrZT<<W7AueD@q3Wa@$&6?WP{4IK_e4z&4Q}R@IdeK5}OM
zCj(XWrn*n0D<@}krgHQMZ;6rYK7oiyOy%x@^sO`755h2gEN&MZcG@>cH$2|n-VtKo
zNz6uG53<?AeIu*EGOu4y4Oe!vlyg+h{lxb6QjM?bqoL=ZwgfBTdI8G1M_Yarm}XM5
z(N=wl6<dM&Tb;xQeL`FCwTt2f1Z%#&)(@;Pj*DQ)MdSJtqEVdg2!55m>+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&<Ctd05-_IE5t{M^tNHkK6@+%zXa8bo-l~M)WAqZSI}kj@%mRoib4Ar0W5>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#<TRwZq69&<gk{YQrLguq9
zr#{t9W;XC!yuH;x`AEOEk1J73BRND=Sl*<aQg;pJ#4GxZmgD_cO3&CTpI7W^$jctp
ztErq7G$bQxS)B1wh!3MFTq|C_$YDA8nQfus5b0XFDF%qb`2WTh&TowI_BUYO;ebKt
zAim);iT9EwkvS}rc*T^jHZ4Z?$)4{^sTHmq{pv{Hhov7nES&s!keSk6Dwb9^$mD)H
z)m8Wv;1e0LTnPZ29dP^~=<6KdU;IUjfsGLeSlU3q0-oXk0;&YC`BSe$myv|Y(&9;0
zQcyhCQynE8%{vtX_Q@kjS@VRoN~>r}&b3lVGU)1bmtrn5AX1XGz-K7{T5_Pgkp1_8
z?Ynz%U#?@o!=lhR9^za}VFmD%@3*Tyu~_Y9c-lFdITp(&tbCebvA3~BEyI<uJy$UN
zbXj0;cYG#zU{puLCLIG8_n{?e?sg}`?IH}MOaU8YrJ^^n@~cMGy&>KhufrbL2C@zd
z(l<B)U%bR*Ly+CU+sso^ez0EuW(zj~_FEN~a~f(|!pCd(cJgcqj{K&uO89oS@iiR>
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<kV>
zfk&*<b&KTcVX;BYbYDhRejaO^CX(%!4q)T|_it8#O2L!>!-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=G5zT2k<aVcNC6%6lYLFZU*D>9@iqGr@HC3=T`J6zLn$G~~szf`BQ
z7WK73vQ=r4RNpvWcE!raw_vrC_=7Kgk!}4Whu80&T-pT=Rf*)F;@Dk40vLb<WPsoQ
z(mT$cnf;!AjAMoIpnFDrGcDw=tnmmO4<)+1H!a3Nv#l3R#0<&a_MN2YOO;n~?Zzwr
z5<A5uK0R?wOu&saNsOhbJbY5D-qYAw!kOlfuS4T{HG^W+73CsXdd*K>CZDDBnEj_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<z)!n3l-N2f=7$3cp5~*!<up*q>)&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~6I<G;ZRdh`okEI_i&Ef^nP08f6k1FeH7fcd|3ALx@4Kc7s1
z{&)5SSo+1YU&?J3#m}AbO7LjqDZbX*1`;w%k{ftU-$_}~Ba0kO)aH|%J8k8bUNaY-
zMskPKC-F~P<|qH~QB?@rpI*eRvr$g`4u5HoLvCKMT-Q_Hma-Oy#v>4Zqg?Z-8JNl)
zd~=e<Xu>*wJ$X51TVLCx1&1)rmTt5&3VW5LOs9C+n4&Y^&jL}Yqt19Ce_e*|ZFtJ8
zcJ8bBgPwhgB35PQDE4jC4Sqx0R2zNx>|p}Uz7+YW#Vy%K8PoqyZD#>hW%jjkI;B&(
zr5i~J3F+<z>F$t5K#;g}DiRXXNQ=@f9U>ql-AE%K-*v_rE;0X^ar|K2wFH*uxA%MA
zd){-;+0Sz}@b&-@8-%Nw`&k<mE1nO_d6~FMLMi#+N2G2+*`bArE$Q6JH<?I7Yx4wq
zIHpoY$-r=o>hk!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-+(<mNuDDqY)>G_Qy|MmrOnJMMS35Mc=Suswjzg4J|{
ziE{HXEJ^fHFN>?I;<-I{Pv3B|nw%9~KW$H<midcZN|2P0ZJ^Hz>N~=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$24<L~BJoqyCf_@!A7a7|$
zxf+=(szx(2f9$+6u%1tU_tkLGblS{5K=||Q`rs+Yj&Yh)sL^~3=ADn-IcInX(q_{_
zMD1FoEc=M753)LHRh?#0p9G%2#)WP6k7JZ|FH0qi{!kv)8ov9clvklq-mj|TcI*Qx
zSe>Zw#4)F?g@TatCKT^*lddG>sizPh1ZlSkU))BS-HROGSp%;)W+C9?I_vK-xE1~I
z(BO62>;2$QGf2iTyHx%eMi4w>lMQ+F59<ooDR|@?dN#lp4={K8f(_c&W?W_CVcVPU
z8NYS9#ThT*e|RUI0K+jkXuIuBiA&dFgB@DDz}hp2MyA+-HR}ULj%EfNcZn`44ouPE
z-6FxrPg>?r#E-adjluN-svLVv)qKCe<x3Y^yxU6)gJa_nk*pwkWYG=T8APXQw1Sn4
z*}KfTZE0t=?6)k3sQ{@ei4e|kgs16+A}=Cu_O6ebujqE?=Yel?uR3Emkm`>xtOo?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?+<RA7FsvP0X`DGgN`ZXI{J6XT%hCyk*cEagb914*t!9;!(weJ@q?mHR98
za@=J+2<O`n6?Ux-pwfu%;n@|YtjhyKa{<0s|3!Fu4;?PAFaL;f;ok;HpUfAkxT{#Y
z%+k*RWx)ouGQ03};nJ*GCByqtcdGu~toiru{ByzVw{H60m4E)`;$K(0@cW$VY7d@k
z?AqZ1XC8gP7a#C4{m%#P?`%hRYeQQr^M~J8FfASRfY!W5*1!j@o0D~<j4V)P7I?_r
z`Y?fB{BAHbK1Dz^n6`ehv_;jon0q$k6Ksso@B#D0;f2RjDTfBQnRaLeAME{RyGbVB
z0YpD7xC_=C={UIrmCdU6_a#ZV2{GJV|8i7P27x2SzY7*pZ+2HunPfFeA#bF(bPbU$
zO#D%DHY+~9*;ZTZhB-x&zck}AUbq{l)8z9O%8c3vmgBeJZ)LTln>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?OMg<wvM{qE!7^E#dvn~+Q1OeWuw8PL!_8IcL~
z*9|AGdKXVC(YM5|!yR={R2Q+tBD&YZvRj~_wJBtT%hgOf3&b-5=+Uf5B_85u7Dws%
z%{fVXV+KX#iS&poD2bR;?Kjpklg1S<g3YARlhqvKxvE93QOA<$2ub=yk^xxBwcmi%
zU~cEA5=VPtH#em6YKwS|^1XWsmf&16qHiDebW5hD%(;kgF|so6zNJmE;hQR^B76!3
zE>1Sw$Od7L(DK29T3DA+ngwVbO<~mss>4N20is|v+$eUCkYyFi-s_|b3fa}NB7DWs
zdd2cy%t<b<6~MYM^~l>rQS}{O9&W`tK?B%^bZn<<nWAXk9G`N-di38jR^UV$p+=h8
z0Hk!T<IiVm_2C2R06xO00Pp0bO6nQBouorc)-!}K)_a80lhWA_BZU<Bo<**kRL>f2
z4Tx>r{+jw^MhU4=VZS-1pAJ>h0K!AJF933#QBd303_MCn0n-+&m4<@9J{T&*E<L`1
zI)}&LesbrKq!}MMRmmi{wqT9#AdImdwryb76E7y%m2|(%Rkc_B{<K=u{n<?T@z_d_
zkf?IGMssB$4;L21!iKqNlb;1LRF@l_bE~_u<w5u_>pUvUIGbou$Y@&x#FU<c=pRsk
zcUx#8ij6fia8w}!17rEy0r<z=_TzT`?Kc1MjM&heumQR_c*WNlra>)3cVwJckjUv|
zBE6CDrD(_qM)HeaPK1-8p@?hY*xTZLNv(nNKEbGJto-1yaa1#DE4Qgr&~{X|B%L^v
zUITknnklA}gB<k96SH_Y`Q%RnC=Jxo#;omi-0e&r#uhLF0xb8WSdrRLFkA&&APh4?
z23bR$sA#qWT0ZWEZk^DCYz`2Le~n~WA4KDv^VEyvR{1F9$B&Nu*iR?kTK%i<i#YI<
zoRHzRm$-bmrxpxEAx1_`1I><-<T7&rRH&X*>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_<OWC^@<GOkKd@;TGN%MwD*Keq|~hvR*fkz&!#fovYa@jP9E(~4|w!YwLNNtaYVHO
z(YC{!8UEWHqvPy=V*~MBq|Tj{okf$QmEzgy676JL|6qZ@h5eq9u~uT{PCan<JhJG)
z$PiRL`^E6lATI+jX=-dG>M$45Mk#pxNP$5iZ^3W1qTWbh90;Cj$n+0*e6WzB&Be2m
zyCQp)-sM*7BbkV3QHFe0Sbaj@sQOh98i8^?2(^t>HWyvM{3ZO?20}6JK*`tDGL$2M
zU!}9D#{)7Hvd73<g^~vB10OU<bXR8f#M*yN@3-Y0pd+?59`=*liji|qxbMzndGJs=
zh6%ssvj<%^CM$Idx`7hQEPE`aU)Rfh8@E9vqa)oZHEp-l(GOz!t!Tc5RNCh*?3o6{
z!KL|oWmt7)YQh_<z5ZCXqlUwdQ?8Aa$*OjrjJ2VK*z6{iT)@>HRaB*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^d<L27CVYGyeL5Nsv9(F`;Ari+~Nx6F+&S@as7
z(HIkMx9Ap5;G_zXB_u0$3$^Y+XOb*$;X~uMJBzGXi#V~b4FFEyt&JYXF0I;p%C{!G
zvx#oqv>Ne5m>{l$P-SC4$-T&`IST!i6^Rj58XtH<z^l)#@E<syeRQP`nM+NJH)81?
ztG46S!M)>OX<Rm4CLY)QDm7`u&ILgCoQ1<|TveI@+obPwpDZh@iM=9)5x^w-6#p?F
z%_LF|oPgtC{ky?i+Y8aIq`pHfdo^9px6!=uQ_68aQbMmajdkfzW%RfOxjb=2w0NIH
zu2}y9hv;NetF1U=^28H=b?5nx>g_pN*El4mK0TN-(XX@(^_JNdsvEY+FCU$>oXF|d
zX2qP}6+Ps^`<M`j)LHx7e?Nw`ISF}Un{Xf-SBbfq6QMnxItqQX8K+jl*h3`D{3tEx
zP_22<zP_GJH$v<<JG!fk!<+CSl2uYaIn}wbGGRCb`5TnnN4&~s-tOM~Z>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<yfdg@Cn
z__k@UJ7cn^vFv~XtqsA?%d)OJ$LBFd(I(_1n;5s1BKMYJB@o6Jl4&Qc*zx(3<O5w0
z_HbtVS8#<tq29&!Z6ACr13_BxCFI1FXUi}_PlT0q9`_-(yqeM$fo7q9Css_z_E6fQ
zyz*S|aO_%O75C?|j$1azBQGHts6LtVI-xJuWKtq>=>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$5IqCh6ant99<b+jXcc(28As}_L^qQvbUULD
zv&V6{w_rX+^EW9>OB4{>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*!8LLHb2<s7?NG9JZdd}h)|99V(LXR
zgTdQVl;d97S@8_7L{}u-v)Ud@a^S?q@Q3h%M?K~FsMH}7rwzwJ7WR;&MF-u)P$eKJ
zI`74RIiJ5(p;R72ZGneF9-fMVjV1IGwYOWnU6|J4<(0~+Wcfapbxb{bE5iEO`X<!&
z1FOa};_n+8zwj(W4wxGxeRO;!-Z^Re*oDCD-1*VO$V^`Hr%{Q`sQyV?fGI-VF|w^%
z^cvEX82;P(>Uym^<w@}rs@)OzeEH?+f*A3#gtB_)E1FT*;pn5P1-i_-lm1b(CnZua
zyI!<aq#8$<RyiUuPlR!{RU{Y)=X9NHyiAV9L)Kx5rzd>Ew@z9Cr-pf@3v=X+csoK^
zM`Np%l}{_ipi17Ho3II6YV@hz6DDvA$~~fV2XK>%WQQqj-r0~*?B<m96A{ZwoRE=U
zB!6WveX5r|7QEw={e?Ow+2mYy$m$ei3{fHS*VL3H9zz3812utL(f9uL1McN%;P1wv
zzi(0f7(%{(j@?Mnk(=Yf3@XM6Ik!`;#$%vsG~>vW)GlB*!(m{~PtPAfke{cLwG6j3
zwSvvfI6bT&tm;ui+_ThQ)fU7jCg!#69di8q1|Fe49UR85K1W1fo>WCW@9f>#y&y4l
zD(V*BEwn(JQFhEbug~uFw|D!8p)<yo(tLFVx~;`{P{6G!ZOpMWrZ)|+IPp|uM*_s2
z$vjIIHq0`mP|C~xut=@DVB%0#Wx^%zDe^c541mso97_T}GTOXv7ddu-Q6j@U$Oun)
ztC^GU16vwRydW+K&|9YF3Hd$G<c9Q=QH2)|=62Sp*jgUXb?tTgMMIT!+%*Q|5PHnp
zy<gM{zoV)WvuL-77ede!?lG{@<`00_MMkd3ueHEgg|X)$dZQ~BJ~#@lfOp@X)0bBX
zf1X4lt~|3Um9sYwi6W>w5%QZZ`;xP9&f$w3de$n|M3JWTu)3PyuH-##ecCUqn`G$i
z>g=ZsAIdgM7_F4XU+W;-VJe0tB9~j?x%D1~t7<k{@7{kJG_~|Tba$<u<YcdAl=o!s
zaLgytcya4tYBP=YH;)0{`b{tH`mY$T^UI2HmefoIA5MN)W-fB=*wPd$T+?N(Nzq;k
zYvPZlxJ7TK=xPZ0gap80T#5FQKfk7mKvVcVE!VCwb2m|=z7dQ?#-8SEX_ym&MAxIS
zd^5HM|66dv<(7R(=2giuTWbE9HbNSvuGG)kCz%Ro?uAUnbO;^n<FR%yNNPaWeLffP
z@mv}6$dl=ED-2fIW~S)Mn#Mst5FAD=hl%oHb1tKIo9W!0KeOBUw1z~c9#jlQFMb=|
zJphtk7}kKyEjY{kE*}r_^V_&=kS~h3q<Z7$dgp5=_Mp5@Cmok+Ca7EyF?3X0jJ}Z#
zb_;N}rn+}%ck9Bx0c%AFHK8p~RB!8ZF_Z8vVWeslUP<>vl9$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<y`lAvkHXFs4-&2Dc*dLIQ^n}MA>+1Uv^^#
zLz?AyXuR_$)x<WNKCBOd2`~pO(CMGx%4~@>_Zzg*<5I^7GhH%2*4gSyg*4rV<asi2
zNMiZPg3!0bLqx*pfhJwMqu^bGM;K&S$V;t5h%BRxG%Z;KpDNls7%Hg*Ea1`4<Rc&_
zV?vkO9`&e%!Hq=hEj<=&IkK=v3a{3qj7|tysMHwA+z2TorBihtZ^oPJf*z4m80x9h
zI24^k&W6SBTI)f^(3Df9S-A_jE~n5x61<N!$w*d9YND3E6gHlcznG1BVzG&&>}ZYe
zySs|gLM~m(*e5A~Ha&epe6h$RTjH&0=P=@S3|!I^0*<;||MG)3=rYrf&)?5uCoF(I
z%|Tm-G(jzql{5Ekp=+o`<T38}wV_I)cT3`pNvUdT@JccuzVk43E@8-*kaQ*uN%E=V
zUN2b+h^J3fPC!i|Fbfx4gjTAEc`1z$KaWuFe?QnUri5wW)S|AdXm-d})KUqRD?(C@
zWC)#1Vo*^xKzSZ+yd(JDi$K(*TY9*#+`#in7!fK$G05WJH4n&U@`q>KWi-Om(Hr`N
z(xSWP=P9g9mb}a{i&@oJ`=vjc;G&C7&#YT5!^=e5NihuE!w#`54b0Zna*W$t>yU|&
zs-?L#%NnT~D8KKe#rQbnQ<kMBU6b}|JeX1&_HF4mPD2eM3krk$EJX)c2Y_x?>C84I
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
zQZB<cSb9bKuw$By$<F7WTik-4XBOVdP8Uns=~X#HaLIi@MBO-)yZoW9x;CkA(?`(R
zxk~*=ZS)&cF74se2M#7tju#B4FQ%7B+=HvWHG8_OJ&qXTM22faLphWeIx{dE6Wbg)
zPjzw?-@(rCCOY(f)C((G>pn@3vk8N~|78+0U94$tLLyk;;;zyFKF9F|a*+{$yR&=1
zqE4#6ysLgp{(nDQ2zbQak9(+4b;4#s4ApB%O}YodJT5w7D8np{gtHd<bcWq*j|#Qz
zDM2S<RPDrM79-l;)^m+$Y#K`Q!1zdMdv3?Y?nxGkOejy?oqJDbWyKd1;N!?Y(Jom(
z_jomeD~U-5b?&=uSv}Ze5@RFC6^R@`o8|&1Cr!yIA416wZrwO`8cnR&c8F)81P5TQ
zdgGs9QsWlaZJ~ipR~}*Y(t9p5k;{`r3o71n!N@N@GE39f*Ok~7cYo6bqSsa`Kyfiw
z+(9-6F*IO<@0E&}8+T0Bo|d}QIjXu`FvQ}x_49UGO1jZE4cO!A&oV32p<ZE+2r*)I
zqn5-Xa?|0nDJ~fISgqhlB{&>FO2<1P3h7H_t4cAG={<$^7tMUWH*PbwIFz$@tfq(l
zZS$*#+qd;&IZ`UysRqJFPr(^qW-L{;p~^MZfV+6`9lW8<^6<^yqdkja>-?OJnQEri
zfMcA_yG4dmlu+RS<H((${&scjs|=Qc6XV+bCEc~bMo0w7sif7+0l2yqk_<OZcw_3Y
zLpB$DO`I({ongu;lr!%SZmChKMLi$7S|2|_M4o|u;l3h8-@i~&i@3Ud(7eG9NwSi6
zf59MuVp~@k4q3Q|6CUfC`@JQLmv!67xXqFn6wyX~A6s&SWN}MekxFbIJ#B(S=b3%&
zL8_`990m(z_N7=;lfWdNfx*7^L#17RfG^;Y=g|Nh9jkb6_k{U;Ey=0SWKDE6zy8`m
zz!(bLYt?&en8h4DsB@FP!$}LMkf&n-{+Y|)%H&{Opz$QZ^0W;B1``z#Pc*>GHbQ)y
zcCA??lgW25ur)9Vlix|;%SGu8zKBtRDTr+>SNiB2tt|Fp7QX<kXWi#L)rhByw_N?4
zeL*e<0b2WRIq?XXS_WUTN^Nj0#b&2fSmiLIQj}+x*a^;QJe|4d3W{Ye7Aj?r`8%-`
zj0)<sf`GVm4f9fh1?%lMlXqwP)3;J5YQ|9Uf|v;QLro9AMQt~r8ka^{=dEZ?FdOUZ
z=BF(;A#g9;&CQ2cQtTv2<#394pYN55DtmrLF|$)=oYE}lGvPi)_%?Vn+VG<ge!g0{
zC7_yPKB8v`@5}R*L{)iNcRnL|RZ=0S!Qk-rOfSTifz9W;(*X8;$y1#j7c9ywRyZQ~
z8hqB2UF5)(XQGJaV<gg9$(Ckqdht4MlE>fcz{DBMQ?DbkP63WX)SmYh4yi89h!{)0
z^?zOiVSr;ZjkTWe^reJJ?+AC+OINVrFE5dUe9VLw&NMkKeR(q4*k$y#$_fCet2y;d
zX2X^0uq>f<l?aS`I~m+BxgO}z%(R=cs!K_zi@eL=W&f&xL}@Uw(MKT4ZdIpg#C-My
z9?hrHV=nU`-0<@U5sI%n^=LixXTV|_a0pB=OyKUr&8L(B{{Zs!KX;`5JhKe6&Fg2D
zfi(B`UVfK0MQ_+R1w~yy<p&hy^L^<Xc*NlM6V@+{ihmrrW_10`AJEpXpSJ+ox)QKP
z=5JfS@$>~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@v<o?DDfq*
z;`QHNPS9NcApTiJ28zDPck=?y2Q0Y#N%R#L&a2F;W|tRCUSNIguVMaW!k678FVJ9M
z4~YK*9K>t#YPy##BSDGtzleBave!KzLD3N;KcDPhIznE}{IU}yC?1ydm*Fq_LS7Bw
zvWp{V2)+MbA>7y-zgd!8vR?#^B^|h9`;+%Q@c9X9#t54Kcjjd)LQp0=#jj%CnDBK&
zK2W$X<xj&wEigc{y>3hg3S6Q3ufX36he3(I_30&>8Bk(4(@zsG8L(U>UNw2SVEQrt
z8sd%pd6UJ;1=^eCr_p~Ju7D<b-8bce1qO!0`k!c*TvR}*-#hfO2?Z!skmJ`;Z@k3c
z@t39ipm=wn?eI^I5g?lOtLa`=&4cp1xqk)k#ze0x(?P*8JU<QoQAY@x<W2hY3)=C|
zvo5REL6P63fS1L~7eJsPEU?o4C;RbcDf3nIRhjYyeCAi9Z|vRcdgO};fQHe)U8$c;
z|B5>KYTlQ{$e_%fpJ!f|2Vccr)**vpZ3KQg)$7<BFZE3V<ckRQ{{#P$BKK;_mu0^f
zKrpZ!!Jkk067nz8y{fUjpo8E4&+O~Z`0rQvvTF7M2nLq%tB^OQ`(6BWS^o;kRt9RK
ze)5g<hXnC=H7scFen(!FoL)ecff~DCg8a*LFAF^{$iUrf(f`c;U2%Ce-OI90P~`Nl
zLf)9}bp<CV+YWg8!GFBeH|jaBW`9*dc@cxdgP)GzlFaZb@v@Zhf(HhsCH`xOH(u`R
zN<vVyn#6xaUmrTY6R#=)FPPwxzlL~YvNwtQF3_d_82uMgKhQ3{u8_F^0ne?K`<pC(
ziCzXYp6fyx(0KHL0+s*yw)#Du3)#%orZ0<JK$|}Q7foMCUO?Nwu1*1MKU?7+h5qOI
z>Tj#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/vendormodules/tomlish-1.1.2.tm b/src/vendormodules/tomlish-1.1.2.tm
index 9270ca9c..c7da645b 100644
--- a/src/vendormodules/tomlish-1.1.2.tm
+++ b/src/vendormodules/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 <tag> value <something> 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 <tomltag> value <whatever>}
+ #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 <tag> value <etc>} 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 <tag> value <whatever>} 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/vendormodules/tomlish-1.1.1.tm b/src/vendormodules/tomlish-1.1.3.tm
similarity index 75%
rename from src/vendormodules/tomlish-1.1.1.tm
rename to src/vendormodules/tomlish-1.1.3.tm
index 0c8d0b1a..3da39427 100644
--- a/src/vendormodules/tomlish-1.1.1.tm
+++ b/src/vendormodules/tomlish-1.1.3.tm
@@ -7,7 +7,7 @@
# (C) 2024
#
# @@ Meta Begin
-# Application tomlish 1.1.1
+# Application tomlish 1.1.3
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@@ -17,19 +17,20 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
-#[manpage_begin tomlish_module_tomlish 0 1.1.1]
+#[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 --}]
+#[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 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] 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.
@@ -78,7 +79,7 @@ package require logger
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval tomlish {
namespace export {[a-z]*}; # Convention: export all lowercase
- variable types
+ variable types
#IDEAS:
# since get_toml produces tomlish with whitespace/comments intact:
@@ -90,7 +91,7 @@ namespace eval tomlish {
# - 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.
+ # 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"
@@ -106,14 +107,14 @@ namespace eval tomlish {
#TABLE is analogous to a Tcl dict
#WS = inline whitespace
#KEY = bare key and value
- #QKEY = double quoted 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 QKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME]
+ 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
@@ -127,19 +128,19 @@ namespace eval tomlish {
logger::initNamespace ::tomlish
foreach lvl [logger::levels] {
interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl
- log::logproc $lvl tomlish_log_$lvl
+ log::logproc $lvl tomlish_log_$lvl
}
#*** !doctools
#[subsection {Namespace tomlish}]
- #[para] Core API functions for tomlish
+ #[para] Core API functions for tomlish
#[list_begin definitions]
proc tags {} {
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,10 +148,23 @@ 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 {<keytype> <keydata> = <valuedat>} list"
+ error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured {<keytype> <keydata> = <valuedat>} 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/quotedkey won't occur directly inside a barekey/quotedkey
+ #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]
@@ -162,15 +176,15 @@ 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 {
INT - FLOAT - BOOL - DATETIME {
- #simple (non-container, no-substitution) datatype
+ #simple (non-container, no-substitution) datatype
set result [list type $type value $value]
}
STRING - STRINGPART {
@@ -182,26 +196,34 @@ 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 <tag> value <something> 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 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<type> - 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 +231,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
@@ -230,7 +252,7 @@ namespace eval tomlish {
lappend key_hierarchy $val
lappend key_hierarchy_raw $val
}
- QKEY {
+ DQKEY {
lappend key_hierarchy [::tomlish::utils::unescape_string $val]
lappend key_hierarchy_raw \"$val\"
}
@@ -247,62 +269,87 @@ 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} {
-
+ #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 <tag> value <val>} 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 <tag> value <val>} form
+ #A dict within an array encodeded as a type ITABLE value <etc> 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]
-
-
- log::info ">>> processing '$tomlish'<<<"
+ ##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 - QKEY - SQKEY {
- log::debug "--> processing $tag: $item"
+ KEY - DQKEY - SQKEY {
+ log::debug "---> to_dict item: processing $tag: $item"
set key [lindex $item 1]
- if {$tag eq "QKEY"} {
+ 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 "--> 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]
+ 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
@@ -317,138 +364,166 @@ namespace eval tomlish {
set leafkey [lindex $dotted_key_hierarchy 0]
} else {
set table_hierarchy [lrange $dotted_key_hierarchy 0 end-1]
- set table_hierarchy_raw [lrange $dotted_key_hierarchy_raw 0 end-1]
- set leafkey [lindex $dotted_key_hierarchy end]
+ 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
+ lappend pathkeys $k
if {![dict exists $datastructure {*}$pathkeys]} {
- dict set datastructure {*}$pathkeys [list]
+ 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]"
}
}
+ #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]
- dict set datastructure {*}$pathkeys $leafkey $keyval_dict
+ 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]
-
- if {$tablename in $tablenames_seen} {
+ #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 "--> processing $tag (name: $tablename): $item"
- set name_segments [::tomlish::utils::tablename_split $tablename]
+
+ 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_hierarchy [list]
- set table_key_hierarchy_raw [list]
-
- foreach rawseg $name_segments {
-
- set seg [::tomlish::utils::normalize_key $rawseg] ;#strips one level of enclosing quotes, and substitutes only toml-specified escapes
- set c1 [tcl::string::index $rawseg 0]
- set c2 [tcl::string::index $rawseg end]
- if {($c1 eq "'") && ($c2 eq "'")} {
- #single quoted segment. No escapes are processed within it.
- set seg [tcl::string::range $rawseg 1 end-1]
- } elseif {($c1 eq "\"") && ($c2 eq "\"")} {
- #double quoted segment. Apply escapes.
- set seg [::tomlish::utils::unescape_string [tcl::string::range $rawseg 1 end-1]]
- } else {
- set seg $rawseg
- }
-
- #no need to check for empty segments here - we've already called tablename_split which would have raised an error for empty segments.
- #if {$rawseg eq ""} {
- # error "Table name '[lindex $item 1]' is not valid. All segments (parts between dots) must be non-empty"
- #}
- lappend table_key_hierarchy $seg
- 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 ?
-
- set testkey [join $table_key_hierarchy_raw .]
-
- set testkey_length [llength $table_key_hierarchy_raw]
+
+ 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 {"x<rawtab>y"}
+
+ set sublist_length [llength $table_key_sublist]
set found_testkey 0
- if {$testkey in $tablenames_seen} {
+ if {$table_key_sublist in $tablenames_seen} {
set found_testkey 1
} else {
#see if it was defined by a longer entry
- foreach seen $tablenames_seen {
- set seen_segments [::tomlish::utils::tablename_split $seen]
- #these are raw unnormalized tablename segments. Need to normalize the double-quoted ones,
- # and strip the quotes from both single-quoted and double-quoted 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'
-
- #VVV the test below is wrong VVV!
- #we need to normalize the tablenames seen so that {"x\ty"} matches {"x<rawtab>y"}
-
- set seen_match [join [lrange $seen_segments 0 [expr {$testkey_length -1}]] .]
- puts stderr "testkey:'$testkey' vs seen_match:'$seen_match'"
- if {$testkey eq $seen_match} {
+ 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 [join $table_key_hierarchy_raw .] already exists in datastructure, but wasn't defined by a supertable."
- append msg "tablenames_seen:"
+ 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
+ lappend table_keys $k
if {![dict exists $datastructure {*}$table_keys]} {
- dict set datastructure {*}$table_keys [list]
+ 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]"
}
}
-
+
#We must do this after the key-collision test above!
- lappend tablenames_seen $tablename
-
-
- log::debug ">>>>>>>>>>>>>>>>>>>>table_key_hierarchy : $table_key_hierarchy"
- log::debug ">>>>>>>>>>>>>>>>>>>>table_key_hierarchy_raw: $table_key_hierarchy_raw"
-
+ 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]
- 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' "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
@@ -457,7 +532,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,12 +540,27 @@ 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 <tomltag> value <whatever>}
+ #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 <tag> value <etc>} 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 - QKEY - SQKEY {
+ KEY - DQKEY - SQKEY {
#obsolete ?
set keyval_key [lindex $element 1]
- if {$type eq "QKEY"} {
+ if {$type eq "DQKEY"} {
set keyval_key [::tomlish::utils::unescape_string $keyval_key]
}
if {[dict exists $datastructure {*}$dotted_key_hierarchy $keyval_key]} {
@@ -483,7 +573,7 @@ namespace eval tomlish {
#ignore
}
default {
- error "Sub element of type '$type' not understood in table context. Expected only KEY,QKEY,SQKEY,NEWLINE,COMMENT,WS"
+ error "Sub element of type '$type' not understood in table context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS"
}
}
}
@@ -495,11 +585,11 @@ namespace eval tomlish {
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 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]
@@ -511,7 +601,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]"
}
}
@@ -525,7 +615,7 @@ namespace eval tomlish {
#ignore
}
default {
- error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,QKEY,SQKEY,NEWLINE,COMMENT,WS"
+ error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS"
}
}
}
@@ -534,9 +624,10 @@ namespace eval tomlish {
#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]
@@ -550,9 +641,20 @@ namespace eval tomlish {
set value [lindex $element 1]
lappend datastructure [list type $type value $value]
}
- ITABLE - TABLE - ARRAY - MULTISTRING - MULTILITERAL {
- set value [lindex $element 1]
- lappend datastructure [list type $type value [::tomlish::get_dict [list $element]]]
+ 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
@@ -576,10 +678,10 @@ namespace eval tomlish {
# def
# etc
# '''
- # - we would like to trimleft each line to the column following the opening delim
+ # - we would like to trimleft each line to the column following the opening delim
# -------------------------------------------------------------------------
- log::debug "--> processing multiliteral: $item"
+ 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
@@ -608,7 +710,7 @@ namespace eval tomlish {
}
MULTISTRING {
#triple dquoted string
- log::debug "--> processing multistring: $item"
+ log::debug "---> to_dict processing multistring: $item"
set stringvalue ""
set idx 0
set parts [lrange $item 1 end]
@@ -620,7 +722,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 {
@@ -662,7 +764,7 @@ namespace eval tomlish {
}
set trimming 0
} else {
- set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS]
+ 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
@@ -673,7 +775,7 @@ namespace eval tomlish {
}
}
}
- }
+ }
}
NEWLINE {
#if newline is first element - it is not part of the data of a multistring
@@ -697,7 +799,7 @@ namespace eval tomlish {
set datastructure $stringvalue
}
WS - COMMENT - NEWLINE {
- #ignore
+ #ignore
}
default {
error "Unexpected tag '$tag' in Tomlish list '$tomlish'"
@@ -707,6 +809,358 @@ 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
+ #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 <typename> value <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]]
@@ -718,8 +1172,12 @@ namespace eval tomlish {
#TODO use huddle?
proc from_json {json} {
- set jstruct [::tomlish::json_struct $json]
- return [::tomlish::from_json_struct $jstruct]
+ #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} {
@@ -734,7 +1192,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]
}
@@ -747,20 +1205,17 @@ namespace eval tomlish {
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
-
-namespace eval tomlish::encode {
- #*** !doctools
- #[subsection {Namespace tomlish::encode}]
- #[para]
- #[list_begin definitions]
-
- #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness
+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 $s]
+ proc STRING {s} {
+ return [list STRING [::tomlish::utils::rawstring_to_Bstring_with_escaped_controls $s]]
+ }
+ proc LITERAL {litstring} {
+
}
- proc int {i} {
+ 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)
@@ -773,16 +1228,16 @@ namespace eval tomlish::encode {
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} {
+ 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]]
@@ -790,24 +1245,24 @@ namespace eval tomlish::encode {
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]"
+ 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} {
+ 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]"
+ 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} {
+ 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 {[expr {$b && 1}]} {
+ if {$b && 1} {
return [::list BOOL true]
} else {
return [::list BOOL false]
@@ -815,13 +1270,12 @@ namespace eval tomlish::encode {
}
}
-
- #TODO
- #Take tablename followed by
- # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]}
+ #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 <keyname> value {STRING <value>})
# 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} {
+ proc _table {name args} {
set pairs [list]
foreach t $args {
if {[llength $t] == 4} {
@@ -832,7 +1286,7 @@ namespace eval tomlish::encode {
if {[llength $valuepart] != 2} {
error "supplied value must be typed. e.g {INT 1} or {STRING test}"
}
- lappend pairs [list KEY $keystr = $valuepart]
+ lappend pairs [list KEY $keystr = $valuepart]
} elseif {[llength $t] == 2} {
#!todo - type heuristics
lassign $t n v
@@ -843,39 +1297,59 @@ namespace eval tomlish::encode {
}
set result [list TABLE $name {NEWLINE lf}]
foreach p $pairs {
- lappend result $p {NEWLINE lf}
+ lappend result $p {NEWLINE lf}
}
return $result
#return [list TABLE $name $pairs]
}
+ #REVIEW - root & table are not correct
#the tomlish root is basically a nameless table representing the root of the document
- proc root {args} {
+ proc _root {args} {
set table [::tomlish::encode::table TOMLISH {*}$args]
- set result [lrange $table 2 end]
+ set result [lrange $table 2 end]
}
+}
+
+namespace eval tomlish::encode {
+ #*** !doctools
+ #[subsection {Namespace tomlish::encode}]
+ #[para]
+ #[list_begin definitions]
+
+
+
+
#WS = whitepace, US = underscore
+ #---------------------------------------------------------------------------------------------------------
+ #NOTE - this DELIBERATELY does not validate the data, or process escapes etc
+ #It encodes the tomlish records as they are.
+ #ie it only produces toml shaped data from a tomlish list.
+ #It is part of the roundtripability of data from toml to tomlish
+ #e.g duplicate keys etc can exist in the toml output.
+ #The to_dict from_dict (or any equivalent processor pair) is responsible for validation and conversion
+ #back and forth of escape sequences where appropriate.
+ #---------------------------------------------------------------------------------------------------------
proc tomlish {list {context ""}} {
if {![tcl::string::is list $list]} {
error "Supplied 'tomlish' is not a valid Tcl list. Expected a tagged list (parsed Toml)"
}
set toml "" ;#result string
-
+
foreach item $list {
set tag [lindex $item 0]
#puts "tomlish::encode::tomlish processing item '$item', tag '$tag'"
#during recursion, some tags require different error checking in different contexts.
set nextcontext $tag ;
-
-
+
#Handle invalid tag nestings
switch -- $context {
- QKEY -
+ DQKEY -
SQKEY -
KEY {
- if {$tag in {KEY QKEY SQKEY}} {
+ if {$tag in {KEY DQKEY SQKEY}} {
error "Invalid tag '$tag' encountered within '$context'"
}
}
@@ -896,12 +1370,12 @@ namespace eval tomlish::encode {
#no context, or no defined nesting error for this context
}
}
-
+
switch -- $tag {
TOMLISH {
#optional root tag. Ignore.
}
- QKEY -
+ DQKEY -
SQKEY -
KEY {
#
@@ -910,7 +1384,7 @@ namespace eval tomlish::encode {
} elseif {$tag eq "SQKEY"} {
append toml '[lindex $item 1]' ;#SQuoted Key
} else {
- append toml \"[lindex $item 1]\" ;#Quoted Key
+ append toml \"[lindex $item 1]\" ;#DQuoted Key
}
#= could be at various positions depending on WS
foreach part [lrange $item 2 end] {
@@ -922,7 +1396,7 @@ namespace eval tomlish::encode {
}
}
DOTTEDKEY {
- #QKEY, SQKEY, BAREKEY, WS, DOTSEP
+ #DQKEY, SQKEY, BAREKEY, WS, DOTSEP
foreach part [lindex $item 1] {
append toml [::tomlish::encode::tomlish [list $part] $nextcontext]
}
@@ -938,11 +1412,10 @@ namespace eval tomlish::encode {
}
}
TABLE {
- append toml "\[[lindex $item 1]\]" ;#table name
+ append toml "\[[lindex $item 1]\]" ;#table name
foreach part [lrange $item 2 end] {
append toml [::tomlish::encode::tomlish [list $part] $nextcontext]
}
-
}
ITABLE {
#inline table - e.g within array or on RHS of keyval/qkeyval
@@ -953,7 +1426,6 @@ namespace eval tomlish::encode {
append toml "\{$data\}"
}
ARRAY {
-
set arraystr ""
foreach part [lrange $item 1 end] {
append arraystr [::tomlish::encode::tomlish [list $part] $nextcontext]
@@ -984,6 +1456,7 @@ namespace eval tomlish::encode {
append toml "\\"
}
STRING {
+ #Basic string (Bstring)
#simple double quoted strings only
#
append toml \"[lindex $item 1]\"
@@ -1007,7 +1480,7 @@ namespace eval tomlish::encode {
append toml [lindex $item 1]
}
MULTILITERAL {
- #multiliteral could be handled as a single literal if we allowed literal to contain newlines
+ #multiliteral could be handled as a single literal if we allowed literal to contain newlines
#- except that the first newline must be retained for roundtripping tomlish <-> toml but
# the first newline is not part of the data.
# we elect instead to maintain a basic LITERALPART that must not contain newlines..
@@ -1039,7 +1512,7 @@ namespace eval tomlish::encode {
error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command."
}
}
-
+
}
return $toml
}
@@ -1054,32 +1527,35 @@ namespace eval tomlish::encode {
#(encode tomlish as toml)
interp alias {} tomlish::to_toml {} tomlish::encode::tomlish
-#
+#
namespace eval tomlish::decode {
#*** !doctools
#[subsection {Namespace tomlish::decode}]
- #[para]
+ #[para]
#[list_begin definitions]
- #return a Tcl list of tomlish tokens
+ #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 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.
# 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
+ #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
+ #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 cr crlf line-endings will be correctly interpreted and can be 'roundtripped'
+ # 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
@@ -1088,73 +1564,70 @@ namespace eval tomlish::decode {
set s [join $args \n]
- namespace upvar ::tomlish::parse is_parsing is_parsing
+ 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
+
+ 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
+
+ namespace upvar ::tomlish::parse lastChar lastChar
set lastChar ""
-
+
set result ""
- namespace upvar ::tomlish::parse nest nest
+ 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
+
+ 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
+ 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]
+ 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
@@ -1162,7 +1635,7 @@ namespace eval tomlish::decode {
#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)]]
@@ -1175,23 +1648,23 @@ namespace eval tomlish::decode {
# ---------------------------------------------------------
if {$space_action eq "pop"} {
- #pop_trigger_tokens: newline tablename endarray endinlinetable
+ #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
+ 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
+ # - 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?
+ #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}]
}
@@ -1213,7 +1686,7 @@ namespace eval tomlish::decode {
switch -- [lindex $lastpart 0] {
LITERALPART {
set newval "[lindex $lastpart 1]'"
- set parentdata $v($parentlevel)
+ set parentdata $v($parentlevel)
lset parentdata end [list LITERALPART $newval]
set v($parentlevel) $parentdata
}
@@ -1234,7 +1707,7 @@ namespace eval tomlish::decode {
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
+ #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}]
@@ -1243,7 +1716,7 @@ namespace eval tomlish::decode {
switch -- [lindex $lastpart 0] {
LITERALPART {
set newval "[lindex $lastpart 1]''"
- set parentdata $v($parentlevel)
+ set parentdata $v($parentlevel)
lset parentdata end [list LITERALPART $newval]
set v($parentlevel) $parentdata
}
@@ -1261,7 +1734,7 @@ namespace eval tomlish::decode {
}
}
}
- puts "---- HERE squote_seq pop <$tok>"
+ puts stderr "tomlish::decode::toml ---- HERE squote_seq pop <$tok>"
}
triple_squote {
#presumably popping multiliteral-space
@@ -1296,10 +1769,19 @@ namespace eval tomlish::decode {
set v($nest) $merged
}
equal {
- if {$prevstate eq "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}]
+ #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 {
@@ -1338,12 +1820,12 @@ namespace eval tomlish::decode {
}
incr nest -1
-
+
} elseif {$last_space_action eq "push"} {
set prevnest $nest
incr nest 1
set v($nest) [list]
- # push_trigger_tokens: barekey quotedkey startinlinetable startarray tablename tablearrayname
+ # push_trigger_tokens: barekey dquotedkey startinlinetable startarray tablename tablearrayname
switch -exact -- $tokenType {
@@ -1365,6 +1847,19 @@ namespace eval tomlish::decode {
#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 {
@@ -1374,7 +1869,7 @@ namespace eval tomlish::decode {
#todo - check not something already waiting?
set waiting [tomlish::parse::get_token_waiting]
if {[llength $waiting]} {
- set i [dict get $waiting startindex]
+ 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 {
@@ -1382,28 +1877,23 @@ namespace eval tomlish::decode {
}
}
startsquote {
+ #JMN
set next_tokenType_known 1
::tomlish::parse::set_tokenType "squotedkey"
set tok ""
}
- quotedkey - itablequotedkey {
- set v($nest) [list QKEY $tok] ;#$tok is the keyname
- }
- itablesquotedkey {
- set v($nest) [list SQKEY $tok] ;#$tok is the keyname
- }
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,
+ # 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
+ # 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
@@ -1434,13 +1924,17 @@ namespace eval tomlish::decode {
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]
+ 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]
@@ -1473,10 +1967,10 @@ namespace eval tomlish::decode {
}
quoted-key {
set next_tokenType_known 1
- ::tomlish::parse::set_tokenType "quotedkey"
+ ::tomlish::parse::set_tokenType "dquotedkey"
set tok ""
}
- itable-quoted-key {
+ XXXitable-quoted-key {
set next_tokenType_known 1
::tomlish::parse::set_tokenType "itablequotedkey"
set tok ""
@@ -1498,7 +1992,7 @@ namespace eval tomlish::decode {
::tomlish::parse::set_tokenType "squotedkey"
set tok ""
}
- itable-squoted-key {
+ XXXitable-squoted-key {
set next_tokenType_known 1
::tomlish::parse::set_tokenType "itablesquotedkey"
set tok ""
@@ -1542,7 +2036,7 @@ namespace eval tomlish::decode {
double_squote {
switch -exact -- $prevstate {
keyval-value-expected {
- lappend v($nest) [list LITERAL ""]
+ lappend v($nest) [list LITERAL ""]
}
multiliteral-space {
#multiliteral-space to multiliteral-space
@@ -1566,9 +2060,6 @@ namespace eval tomlish::decode {
literalpart {
lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly
}
- quotedkey {
- #lappend v($nest) [list QKEY $tok] ;#TEST
- }
itablequotedkey {
}
@@ -1621,20 +2112,20 @@ namespace eval tomlish::decode {
}
}
}
-
+
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
@@ -1643,21 +2134,21 @@ namespace eval tomlish::decode {
::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)
}
@@ -1670,7 +2161,7 @@ interp alias {} tomlish::from_toml {} tomlish::decode::toml
namespace eval tomlish::utils {
#*** !doctools
#[subsection {Namespace tomlish::utils}]
- #[para]
+ #[para]
#[list_begin definitions]
@@ -1690,7 +2181,7 @@ namespace eval tomlish::utils {
}
#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
+ #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 ""
@@ -1701,7 +2192,7 @@ namespace eval tomlish::utils {
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
+ set had_slash 0
} else {
set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c]
switch -- $ctype {
@@ -1713,7 +2204,7 @@ namespace eval tomlish::utils {
}
bsl {
set had_slash 1
- }
+ }
}
}
} else {
@@ -1754,15 +2245,15 @@ namespace eval tomlish::utils {
#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 {
@@ -1796,10 +2287,16 @@ namespace eval tomlish::utils {
set mode "quoted"
set seg "\""
} elseif {$mode eq "unquoted"} {
- append seg $c
+ append seg $c
} elseif {$mode eq "quoted"} {
append seg $c
- lappend segments $seg
+
+ 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"} {
@@ -1816,16 +2313,17 @@ namespace eval tomlish::utils {
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
@@ -1844,16 +2342,17 @@ namespace eval tomlish::utils {
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 $seg
- } else {
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
+ #lappend segments [subst -nocommands -novariables [::string range $seg 1 end-1]] ;#wrong
+ } else {
+ lappend segments $seg
}
}
litquoted {
@@ -1877,7 +2376,7 @@ namespace eval tomlish::utils {
}
foreach seg $segments {
set trimmed [tcl::string::trim $seg " \t"]
- #note - we explicitly allow 'empty' quoted strings '' & ""
+ #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"
@@ -1891,8 +2390,8 @@ namespace eval tomlish::utils {
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'
+ # 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]} {
@@ -1925,30 +2424,73 @@ namespace eval tomlish::utils {
}
} 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\<newline><whitespace> with a single whitespace
+ # it replaces \<newline><whitespace> 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} {} {
@@ -1957,15 +2499,21 @@ namespace eval tomlish::utils {
} else {
set lastChar ""
}
-
+
set c [tcl::string::index $str $i]
- ::tomlish::log::debug "unescape_string. got char $c"
+ #::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} {
@@ -1976,14 +2524,14 @@ namespace eval tomlish::utils {
} elseif {$unicode8_active} {
error "unescape_string. unexpected case slash during unicode8 not yet handled"
} else {
- # don't output anything (yet)
+ # 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
@@ -1997,7 +2545,7 @@ namespace eval tomlish::utils {
} 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
@@ -2030,11 +2578,13 @@ namespace eval tomlish::utils {
}
default {
set slash_active 0
-
- append buffer "\\"
+ #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
}
@@ -2042,10 +2592,10 @@ namespace eval tomlish::utils {
}
#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"
+ 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"
+ error "End of string reached before complete unicode escape sequence \UHHHHHHHH"
}
if {$slash_active} {
append buffer "\\"
@@ -2053,6 +2603,9 @@ namespace eval tomlish::utils {
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]
@@ -2063,41 +2616,57 @@ namespace eval tomlish::utils {
#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 c
- append rv {\u}
- append rv [format %.4X $c]
+ 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.
+ #'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 c
-
+ scan $i %c cdec
+
set printable 0
- if {($c>31) && ($c<127)} {
+ if {($cdec>31) && ($cdec<127)} {
set printable 1
}
- if {$printable} {append res $i} else {append res \\u[format %.4X $c]}
+ if {$printable} {
+ append res $i
+ } else {
+ if {$cdec > 65535} {
+ append res \\U[format %.8X $cdec]
+ } else {
+ append res \\u[format %.4X $cdec]
+ }
+ }
}
set res
- } ;#RS
+ } ;# initial version from tcl wiki 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 +2680,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]
@@ -2132,25 +2747,25 @@ namespace eval tomlish::utils {
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
+ # ---------------------------------------
+ #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
+ return 0
}
if {[tcl::string::last + $str] > 0} {
- return 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)
@@ -2158,7 +2773,7 @@ namespace eval tomlish::utils {
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.
+ #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} {
@@ -2195,7 +2810,7 @@ namespace eval tomlish::utils {
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)
@@ -2215,14 +2830,14 @@ namespace eval tomlish::utils {
#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
}
@@ -2240,7 +2855,7 @@ namespace eval tomlish::utils {
}
}
- #review - we
+ #review - we
proc is_datetime {str} {
#e.g 1979-05-27
#e.g 1979-05-27T00:32:00Z
@@ -2249,14 +2864,14 @@ namespace eval tomlish::utils {
#e.g 1979-05-27 00:32:00.999999-07:00
#review
- #minimal datetimes?
+ #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
@@ -2264,8 +2879,8 @@ namespace eval tomlish::utils {
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
- #
+ #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
@@ -2286,7 +2901,7 @@ namespace eval tomlish::utils {
namespace eval tomlish::parse {
#*** !doctools
#[subsection {Namespace tomlish::parse}]
- #[para]
+ #[para]
#[list_begin definitions]
#This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases.
@@ -2294,16 +2909,16 @@ namespace eval tomlish::parse {
# - 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?
+
+ #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:
+ variable state
+ # states:
# table-space, itable-space, array-space
# value-expected, keyval-syntax,
# quoted-key, squoted-key
@@ -2318,10 +2933,10 @@ namespace eval tomlish::parse {
#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)
+ # - 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
+ #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
@@ -2334,24 +2949,24 @@ namespace eval tomlish::parse {
# 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 <state-space>} or POPSPACE or SAMESPACE
+ #If 1 element - it is either a lowercase dashed state name or an ucase instruction
+ #e.g {PUSHSPACE <state-space>} 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
+ variable stateMatrix
set stateMatrix [dict create]
#xxx-space vs xxx-syntax inadequately documented - TODO
# --------------------------------------------------------------------------------------------------------------#
- # incomplete example of some state starting at table-space
+ # 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^) (startquote -> quoted-key ^)
+ # table-space (barekey^) (startdquote -> dquoted-key ^)
# --------------------------------------------------------------------------------------------------------------#
dict set stateMatrix\
@@ -2361,7 +2976,8 @@ namespace eval tomlish::parse {
newline "table-space"\
barekey {PUSHSPACE "keyval-space" state "keyval-syntax"}\
squotedkey {PUSHSPACE "keyval-space" state "keyval-syntax" note ""}\
- startquote "quoted-key"\
+ dquotedkey {PUSHSPACE "keyval-space" state "keyval-syntax"}\
+ XXXstartquote "quoted-key"\
XXXstartsquote "squoted-key"\
comment "table-space"\
starttablename "tablename-state"\
@@ -2371,6 +2987,7 @@ namespace eval tomlish::parse {
comma "err-state"\
eof "end-state"\
equal "err-state"\
+ cr "err-lonecr"\
}
#itable-space/ curly-syntax : itables
@@ -2378,16 +2995,17 @@ namespace eval tomlish::parse {
itable-space {\
whitespace "itable-space"\
newline "itable-space"\
- squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-space starttok {squote_seq "'"}}\
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"\
- startquote "quoted-key"\
- startsquote {TOSTATE "squoted-key" comment "jn-testing"}\
- comma "itable-space"\
- comment "err-state"\
+ 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\
@@ -2400,8 +3018,9 @@ namespace eval tomlish::parse {
dict set stateMatrix\
keyval-syntax {\
whitespace "keyval-syntax"\
- squotedkey {PUSHSPACE "dottedkey-space"}\
barekey {PUSHSPACE "dottedkey-space"}\
+ squotedkey {PUSHSPACE "dottedkey-space"}\
+ dquotedkey {PUSHSPACE "dottedkey-space"}\
equal "keyval-value-expected"\
comma "err-state"\
newline "err-state"\
@@ -2443,8 +3062,9 @@ namespace eval tomlish::parse {
dict set stateMatrix\
itable-keyval-syntax {\
whitespace "itable-keyval-syntax"\
- squotedkey {PUSHSPACE "dottedkey-space"}\
barekey {PUSHSPACE "dottedkey-space"}\
+ squotedkey {PUSHSPACE "dottedkey-space"}\
+ dquotedkey {PUSHSPACE "dottedkey-space"}\
equal "itable-keyval-value-expected"\
newline "err-state"\
eof "err-state"\
@@ -2473,8 +3093,8 @@ namespace eval tomlish::parse {
whitespace "itable-val-tail"\
endinlinetable "POPSPACE"\
comma "POPSPACE"\
- Xnewline {TOSTATE "itable-val-tail" note "itable-space ??"}\
- newline "err-state"\
+ XXXnewline {TOSTATE "itable-val-tail" note "itable-space ??"}\
+ newline "POPSPACE"\
comment "itable-val-tail"\
eof "err-state"\
}
@@ -2512,41 +3132,68 @@ namespace eval tomlish::parse {
newline "err-state"\
eof "err-state"\
}
-
- #dottedkey-space is not used within [tablename] or [[tablearrayname]]
+
+ #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 "dottedkey-space"\
- barekey "dottedkey-space"\
- squotedkey "dottedkey-space"\
- quotedkey "dottedkey-space"\
- equal "POPSPACE"\
+ 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 <x>
+ # 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
- 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"\
- }
+
+ #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?
@@ -2589,10 +3236,19 @@ namespace eval tomlish::parse {
dict set stateMatrix\
quoted-key {\
whitespace "NA"\
- quotedkey {PUSHSPACE "keyval-space"}\
+ 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"\
@@ -2600,7 +3256,7 @@ namespace eval tomlish::parse {
newline "err-state"\
}
# endsquote {PUSHSPACE "keyval-space"}
-
+
dict set stateMatrix\
string-state {\
whitespace "NA"\
@@ -2654,7 +3310,7 @@ namespace eval tomlish::parse {
trailing-squote-space {\
squote_seq "POPSPACE"\
}
-
+
dict set stateMatrix\
tablename-state {\
@@ -2706,9 +3362,9 @@ namespace eval tomlish::parse {
}
- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
#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]
@@ -2725,17 +3381,17 @@ namespace eval tomlish::parse {
}
}
::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
+ #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'
+ #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
@@ -2745,7 +3401,7 @@ namespace eval tomlish::parse {
array-space array-space
table-space tablename-state
}
- #itable-space itable-space
+ #itable-space itable-space
#Pop to, next
variable spacePopTransitions {
array-space array-syntax
@@ -2777,7 +3433,7 @@ namespace eval tomlish::parse {
variable nest
variable v
- set prevstate $currentstate
+ set prevstate $currentstate
variable spacePopTransitions
@@ -2787,10 +3443,10 @@ namespace eval tomlish::parse {
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"
@@ -2806,10 +3462,10 @@ namespace eval tomlish::parse {
if {[dict exists $parent_info returnstate]} {
set next [dict get $parent_info returnstate]
- #clear the returnstate on current level
+ #clear the returnstate on current level
set existing [spacestack pop]
dict unset existing returnstate
- spacestack push $existing ;#re-push modification
+ spacestack push $existing ;#re-push modification
::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace redirected to stored returnstate $next <<---"
} else {
###
@@ -2833,10 +3489,10 @@ namespace eval tomlish::parse {
if {[dict exists $currentspace_info returnstate]} {
set next [dict get $currentspace_info returnstate]
- #clear the returnstate on current level
+ #clear the returnstate on current level
set existing [spacestack pop]
dict unset existing returnstate
- spacestack push $existing ;#re-push modification
+ 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]} {
@@ -2859,7 +3515,7 @@ namespace eval tomlish::parse {
set last_space_action "pop"
set last_space_type $type
-
+
#-----
#standard pop
set parentlevel [expr {$nest -1}]
@@ -2867,8 +3523,8 @@ namespace eval tomlish::parse {
incr nest -1
#-----
}
- #re-entrancy
-
+ #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"
@@ -2890,7 +3546,7 @@ namespace eval tomlish::parse {
if {[dict exists $transition_to starttok]} {
set starttok [dict get $transition_to starttok]
}
- spacestack push [dict create type space state $original_target]
+ spacestack push [dict create type space state $original_target]
set last_space_action "push"
set last_space_type "space"
@@ -2928,7 +3584,7 @@ namespace eval tomlish::parse {
}
}
} else {
- ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received"
+ ::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]
@@ -2943,7 +3599,7 @@ namespace eval tomlish::parse {
if {$is_parsing} {
if {$line eq ""} {
set line $linenum
- }
+ }
return "Line Number: $line"
} else {
#not in the middle of parsing tomlish text - return nothing.
@@ -2954,11 +3610,11 @@ namespace eval tomlish::parse {
#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 QKEY SQKEY TABLE ARRAY})} {
+ } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY DQKEY SQKEY TABLE ARRAY})} {
append prettier [nest_pretty1 $el]
} else {
append prettier "[list $el] "
@@ -3002,7 +3658,7 @@ namespace eval tomlish::parse {
puts stderr "_shortcircuit_startquotesequence toklen 2"
set_tokenType "startquote"
set tok "\""
- incr i -2
+ incr i -2
return -level 2 1
}
}
@@ -3023,15 +3679,15 @@ 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 <tokentype> value <value> complete 0|1"
+ error "tomlish set_token_waiting must have args of form: type <tokentype> value <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 "set_token_waiting already has token_waiting: [lindex $token_waiting 0]"
+ #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}]
@@ -3051,19 +3707,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
}
@@ -3076,9 +3732,9 @@ namespace eval tomlish::parse {
return
}
- #returns 0 or 1
+ #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
+ #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?
@@ -3089,25 +3745,25 @@ namespace eval tomlish::parse {
variable tok
variable type ;#character type
variable state ;#FSM
-
-
+
+
variable tokenType
variable tokenType_list
-
-
+
+
variable endToken
-
- variable lastChar
-
+
+ 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
+ variable token_waiting
if {[llength $token_waiting]} {
set waiting [lindex $token_waiting 0]
@@ -3118,7 +3774,7 @@ namespace eval tomlish::parse {
return 1
}
#------------------------------
-
+
set resultlist [list]
set sLen [tcl::string::length $s]
@@ -3132,23 +3788,23 @@ namespace eval tomlish::parse {
} else {
set lastChar ""
}
-
+
set c [tcl::string::index $s $i]
set cindex $i
- tomlish::log::debug "- tokloop char <$c> index $i tokenType:$tokenType tok:<$tok>"
+ 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
-
- set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c]
+
switch -exact -- $ctest {
# {
set dquotes $multi_dquote
- set 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 {
@@ -3164,11 +3820,11 @@ 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
- #do a return for the whitespace, set token_waiting
+ #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
@@ -3181,14 +3837,14 @@ 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
append tok $c
}
default {
- #quotedkey, itablequotedkey, string,literal, multistring
+ #dquotedkey, itablequotedkey, string,literal, multistring
append tok $c
}
}
@@ -3203,7 +3859,7 @@ namespace eval tomlish::parse {
append tok "$dquotes#"
}
multiliteral-space {
- set_tokenType "literalpart"
+ set_tokenType "literalpart"
set tok "#"
}
default {
@@ -3217,7 +3873,7 @@ namespace eval tomlish::parse {
lc {
#left curly brace
set dquotes $multi_dquote
- set multi_dquote ""
+ set multi_dquote ""
set had_slash $slash_active
set slash_active 0
@@ -3235,20 +3891,20 @@ namespace eval tomlish::parse {
set_tokenType "startsquote"
return 1
}
- literal - literalpart - squotedkey - itablesquotedkey {
+ literal - literalpart - squotedkey {
append tok $c
}
- string - quotedkey - itablequotedkey {
+ string - dquotedkey {
if {$had_slash} {append tok "\\"}
append tok $c
}
stringpart {
- if {$had_slash} {append tok "\\"}
+ if {$had_slash} {append tok "\\"}
append tok $dquotes$c
}
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
@@ -3273,7 +3929,7 @@ namespace eval tomlish::parse {
return 1
}
array-space - array-syntax {
- #nested anonymous inline table
+ #nested anonymous inline table
set_tokenType "startinlinetable"
set tok "\{"
return 1
@@ -3281,7 +3937,7 @@ namespace eval tomlish::parse {
table-space {
#invalid - but allow parser statemachine to report it. ?
set_tokenType "startinlinetable"
- set tok "\{"
+ set tok "\{"
return 1
}
multistring-space {
@@ -3293,11 +3949,11 @@ namespace eval tomlish::parse {
append tok "$dquotes\{"
}
multiliteral-space {
- set_tokenType "literalpart"
+ set_tokenType "literalpart"
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]"
}
}
}
@@ -3306,7 +3962,7 @@ namespace eval tomlish::parse {
rc {
#right curly brace
set dquotes $multi_dquote
- set multi_dquote ""
+ set multi_dquote ""
set had_slash $slash_active
set slash_active 0
@@ -3324,33 +3980,31 @@ namespace eval tomlish::parse {
set_tokenType "startsquote"
return 1
}
- literal - literalpart - squotedkey - itablesquotedkey {
+ literal - literalpart - squotedkey {
append tok $c
}
- string - quotedkey - itablequotedkey - comment {
- if {$had_slash} {append tok "\\"}
+ XXXitablesquotedkey {
+ }
+ string - dquotedkey - itablequotedkey - comment {
+ if {$had_slash} {append tok "\\"}
append tok $c
}
stringpart {
- if {$had_slash} {append tok "\\"}
+ if {$had_slash} {append tok "\\"}
append tok $dquotes$c
}
starttablename - tablename {
- if {$had_slash} {append tok "\\"}
+ 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 "\\"}
+ 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
}
- itable-val-tail {
- #review
- error "right-curly in itable-val-tail"
- }
default {
#end any other token
incr i -1
@@ -3363,13 +4017,13 @@ namespace eval tomlish::parse {
value-expected {
#invalid - but allow parser statemachine to report it.
set_tokenType "endinlinetable"
- set tok "\}"
+ set tok "\}"
return 1
}
table-space {
#invalid - but allow parser statemachine to report it. ?
set_tokenType "endinlinetable"
- set tok "\}"
+ set tok "\}"
return 1
}
itable-space {
@@ -3387,7 +4041,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
@@ -3398,7 +4052,7 @@ namespace eval tomlish::parse {
set tok "\}"
return 1
}
- curly-syntax {
+ XXXcurly-syntax {
set_tokenType "endinlinetable"
set tok "\}"
return 1
@@ -3411,7 +4065,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 +4081,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]"
}
}
}
@@ -3436,7 +4090,7 @@ namespace eval tomlish::parse {
lb {
#left square bracket
set dquotes $multi_dquote
- set multi_dquote ""
+ set multi_dquote ""
set had_slash $slash_active
set slash_active 0
@@ -3454,10 +4108,12 @@ namespace eval tomlish::parse {
set_tokenType "startsquote"
return 1
}
- literal - literalpart - squotedkey - itablesquotedkey {
+ literal - literalpart - squotedkey {
append tok $c
}
- string - quotedkey - itablequotedkey {
+ XXXitablesquotedkey {
+ }
+ string - dquotedkey - itablequotedkey {
if {$had_slash} {append tok "\\"}
append tok $c
}
@@ -3473,10 +4129,11 @@ namespace eval tomlish::parse {
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
+ #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 "\\["
+ append tok {\[}
} else {
if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} {
#invalid at this point - state machine should disallow table -> starttablearrayname
@@ -3510,7 +4167,7 @@ namespace eval tomlish::parse {
#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 \[ \[
+ # e.g \[ \[
set_tokenType "starttablename"
set tok "" ;#there is no output into the tomlish list for this token
}
@@ -3519,7 +4176,7 @@ namespace eval tomlish::parse {
set_tokenType "startarray"
set tok "\["
return 1
- #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]"
+ #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]"
}
multistring-space {
set_tokenType "stringpart"
@@ -3533,8 +4190,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=\[<vals>\] 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]"
}
}
}
@@ -3542,10 +4203,10 @@ namespace eval tomlish::parse {
rb {
#right square bracket
set dquotes $multi_dquote
- set multi_dquote ""
+ set multi_dquote ""
set had_slash $slash_active
set slash_active 0
-
+
if {[tcl::string::length $tokenType]} {
switch -exact -- $tokenType {
squote_seq {
@@ -3560,19 +4221,21 @@ namespace eval tomlish::parse {
set_tokenType "startsquote"
return 1
}
- literal - literalpart - squotedkey - itablesquotedkey {
+ literal - literalpart - squotedkey {
append tok $c
}
- string - quotedkey - itablequotedkey {
- if {$had_slash} {append tok "\\"}
+ XXXitablesquotedkey {
+ }
+ string - dquotedkey - itablequotedkey {
+ if {$had_slash} {append tok "\\"}
append tok $c
}
stringpart {
- if {$had_slash} {append tok "\\"}
+ if {$had_slash} {append tok "\\"}
append tok $dquotes$c
}
comment {
- if {$had_slash} {append tok "\\"}
+ if {$had_slash} {append tok "\\"}
append tok $c
}
whitespace {
@@ -3588,7 +4251,7 @@ namespace eval tomlish::parse {
}
}
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
+ #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 "\\]"
@@ -3604,7 +4267,7 @@ namespace eval tomlish::parse {
}
tablearraynames {
#todo?
- if {$had_slash} {append tok "\\"}
+ 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
@@ -3620,13 +4283,13 @@ namespace eval tomlish::parse {
value-expected {
#invalid - but allow parser statemachine to report it.
set_tokenType "endarray"
- set tok "\]"
+ set tok "\]"
return 1
}
table-space {
#invalid - but allow parser statemachine to report it. ?
set_tokenType "endarray"
- set tok "\]"
+ set tok "\]"
return 1
}
tablename-state {
@@ -3639,7 +4302,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 +4325,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]"
}
}
}
@@ -3678,7 +4341,7 @@ namespace eval tomlish::parse {
return 1
}
startquotesequence {
- _shortcircuit_startquotesequence
+ _shortcircuit_startquotesequence
}
_start_squote_sequence {
incr i -[tcl::string::length $tok]
@@ -3691,15 +4354,17 @@ 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 {
- #never need to set slash_active true when in single quoted tokens
+ literal - literalpart - squotedkey {
+ #never need to set slash_active true when in single quoted tokens
append tok "\\"
set slash_active 0
}
- string - quotedkey - itablequotedkey - comment {
+ XXXitablesquotedkey {
+ }
+ string - dquotedkey - itablequotedkey - comment {
if {$slash_active} {
set slash_active 0
append tok "\\\\"
@@ -3718,7 +4383,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 +4394,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,14 +4421,14 @@ 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]"
}
}
}
}
sq {
#single quote
- set had_slash $slash_active
+ set had_slash $slash_active
set slash_active 0
if {[tcl::string::length $tokenType]} {
switch -exact -- $tokenType {
@@ -3776,9 +4441,9 @@ 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 '''
+ return 1 ;#return tok '''
}
}
trailing-squote-space {
@@ -3790,7 +4455,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"
}
}
}
@@ -3811,17 +4476,17 @@ namespace eval tomlish::parse {
2 {
#switch?
append tok $c
- set_tokenType triple_squote
+ set_tokenType triple_squote
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'"
}
}
}
literal {
#slash_active always false
- #terminate the literal
+ #terminate the literal
set_token_waiting type endsquote value "'" complete 1 startindex $cindex
return 1
}
@@ -3834,7 +4499,7 @@ namespace eval tomlish::parse {
incr i -1 ;#throw the "'" back to loop - will be added to an squote_seq token for later processing
return 1
}
- itablesquotedkey {
+ XXXitablesquotedkey {
set_token_waiting type endsquote value "'" complete 1 startindex $cindex
return 1
}
@@ -3851,6 +4516,10 @@ namespace eval tomlish::parse {
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
}
@@ -3858,8 +4527,8 @@ namespace eval tomlish::parse {
} else {
switch -exact -- $state {
value-expected - array-space {
- set_tokenType "_start_squote_sequence"
- set tok "'"
+ set_tokenType "_start_squote_sequence"
+ set tok "'"
}
itable-keyval-value-expected - keyval-value-expected {
set_tokenType "squote_seq_begin"
@@ -3867,18 +4536,26 @@ namespace eval tomlish::parse {
return 1
}
table-space {
- ###
+ #tests: squotedkey.test
set_tokenType "squotedkey"
- set tok ""
+ 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 "'"
+ set tok "'"
return 1
}
tablename-state {
#first char in tablename-state/tablearrayname-state
- set_tokenType tablename
+ set_tokenType tablename
append tok "'"
}
tablearrayname-state {
@@ -3887,16 +4564,16 @@ namespace eval tomlish::parse {
}
literal-state {
tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?"
- set_tokenType literal
+ set_tokenType literal
incr -1
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
- #we are building up an squote_seq to determine if
+ #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
@@ -3908,7 +4585,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]"
}
}
}
@@ -3916,7 +4593,7 @@ namespace eval tomlish::parse {
}
dq {
#double quote
- set had_slash $slash_active
+ set had_slash $slash_active
set slash_active 0
if {[tcl::string::length $tokenType]} {
@@ -3935,7 +4612,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 +4629,7 @@ namespace eval tomlish::parse {
return 1
}
default {
- error "unexpected _start_squote_sequence length $toklen"
+ error "tomlish unexpected _start_squote_sequence length $toklen"
}
}
}
@@ -3963,7 +4640,7 @@ namespace eval tomlish::parse {
if {$had_slash} {
append tok "\\" $c
} else {
- #unescaped quote always terminates a string?
+ #unescaped quote always terminates a string?
set_token_waiting type endquote value "\"" complete 1 startindex $cindex
return 1
}
@@ -3974,9 +4651,9 @@ namespace eval tomlish::parse {
append tok "\\" $c
} else {
#incr i -1
-
+
if {$multi_dquote eq "\"\""} {
- set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex -2}]
+ set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex -2}]
set multi_dquote ""
return 1
} else {
@@ -4024,9 +4701,13 @@ namespace eval tomlish::parse {
# return 1
#}
}
+ table-space - itable-space {
+ incr i -1
+ return 1
+ }
default {
set_token_waiting type startquote value "\"" complete 1 startindex $cindex
- return 1
+ return 1
}
}
}
@@ -4034,7 +4715,7 @@ namespace eval tomlish::parse {
if {$had_slash} {append tok "\\"}
append tok $c
}
- quotedkey - itablequotedkey {
+ XXXdquotedkey - XXXitablequotedkey {
if {$had_slash} {
append tok "\\"
append tok $c
@@ -4043,7 +4724,17 @@ namespace eval tomlish::parse {
return 1
}
}
- squotedkey - itablesquotedkey {
+ 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 {
@@ -4055,7 +4746,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,12 +4761,17 @@ 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
if {$had_slash} {
set_tokenType "stringpart"
- set tok "\\\""
+ set tok "\\\""
set multi_dquote ""
} else {
if {$multi_dquote eq "\"\""} {
@@ -4095,18 +4791,21 @@ namespace eval tomlish::parse {
set_tokenType "literalpart"
set tok "\""
}
- table-space {
+ XXXtable-space {
set_tokenType "startquote"
set tok $c
return 1
}
- itable-space {
+ XXXitable-space {
set_tokenType "startquote"
set tok $c
- return 1
+ }
+ table-space - itable-space {
+ set_tokenType "dquotedkey"
+ set tok ""
}
tablename-state {
- set_tokenType tablename
+ set_tokenType tablename
set tok $c
}
tablearrayname-state {
@@ -4114,11 +4813,15 @@ namespace eval tomlish::parse {
set tok $c
}
dottedkey-space {
- set_tokenType dquote_seq_begin
- set tok $c
+ set_tokenType dquotedkey
+ set tok ""
+
+ #only if complex keys become a thing
+ #set_tokenType dquote_seq_begin
+ #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]"
}
}
}
@@ -4128,7 +4831,7 @@ namespace eval tomlish::parse {
set multi_dquote "" ;#!!
set had_slash $slash_active
set slash_active 0
-
+
if {[tcl::string::length $tokenType]} {
switch -exact -- $tokenType {
squote_seq {
@@ -4147,13 +4850,13 @@ namespace eval tomlish::parse {
#assertion had_slash 0, multi_dquote ""
append tok $c
}
- string - comment - quotedkey - itablequotedkey {
+ string - comment - dquotedkey - itablequotedkey {
#for these tokenTypes an = is just data.
- if {$had_slash} {append tok "\\"}
+ if {$had_slash} {append tok "\\"}
append tok $c
}
stringpart {
- if {$had_slash} {append tok "\\"}
+ if {$had_slash} {append tok "\\"}
append tok $dquotes$c
}
whitespace {
@@ -4172,14 +4875,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 {
@@ -4197,7 +4900,7 @@ namespace eval tomlish::parse {
set tok "="
}
dottedkey-space {
- set_tokenType "equal"
+ set_tokenType "equal"
set tok "="
return 1
}
@@ -4218,6 +4921,13 @@ namespace eval tomlish::parse {
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
@@ -4234,23 +4944,37 @@ 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"
- #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space
+ ::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
+ #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 "Character <carriage return> is invalid first character for $tokenType. [tomlish::parse::report_line]"
+ error "tomlish Character <carriage return> 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
@@ -4264,13 +4988,19 @@ namespace eval tomlish::parse {
}
}
lf {
- # \n newline
+ # \n newline
set dquotes $multi_dquote
set multi_dquote "" ;#!!
- set had_slash $slash_active
+ 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
@@ -4290,17 +5020,11 @@ namespace eval tomlish::parse {
return 1
}
literalpart {
- #we allow newlines - but store them within the multiliteral as their own element
+ #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
}
- 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
- }
stringpart {
if {$dquotes ne ""} {
append tok $dquotes
@@ -4308,7 +5032,7 @@ namespace eval tomlish::parse {
return 1
} else {
if {$had_slash} {
- #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1)
+ #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
@@ -4319,15 +5043,15 @@ namespace eval tomlish::parse {
}
}
starttablename - tablename - tablearrayname - starttablearrayname {
- error "Character <linefeed> is invalid in $tokenType. [tomlish::parse::report_line]"
+ error "tomlish Character <linefeed> 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
-
+ # 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
@@ -4349,14 +5073,14 @@ namespace eval tomlish::parse {
incr i -1
return 1
}
- set_tokenType "newline"
- set tok lf
+ set_tokenType "newline"
+ set tok lf
return 1
}
}
multiliteral-space {
#assert had_slash 0, multi_dquote ""
- set_tokenType "newline"
+ set_tokenType "newline"
set tok "lf"
return 1
}
@@ -4382,7 +5106,7 @@ namespace eval tomlish::parse {
}
, {
set dquotes $multi_dquote
- set multi_dquote ""
+ set multi_dquote ""
set had_slash $slash_active
set slash_active 0
if {[tcl::string::length $tokenType]} {
@@ -4390,7 +5114,7 @@ namespace eval tomlish::parse {
newline {
#incomplete newline
set_tokenType "cr"
- incr i -1
+ incr i -1
return 1
}
squote_seq {
@@ -4406,19 +5130,19 @@ namespace eval tomlish::parse {
return 1
}
comment - tablename - tablearrayname {
- if {$had_slash} {append tok "\\"}
+ if {$had_slash} {append tok "\\"}
append tok ,
}
- string - quotedkey - itablequotedkey {
- if {$had_slash} {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 "\\"}
+ if {$had_slash} {append tok "\\"}
append tok $dquotes$c
}
- literal - literalpart - squotedkey - itablesquotedkey {
+ literal - literalpart - squotedkey {
#assert had_slash always 0, multi_dquote ""
append tok $c
}
@@ -4434,7 +5158,7 @@ namespace eval tomlish::parse {
}
default {
set_token_waiting type comma value "," complete 1 startindex $cindex
- if {$had_slash} {append tok "\\"}
+ if {$had_slash} {append tok "\\"}
return 1
}
}
@@ -4443,12 +5167,12 @@ namespace eval tomlish::parse {
multistring-space {
set_tokenType "stringpart"
set tok ""
- if {$had_slash} {append tok "\\"}
+ if {$had_slash} {append tok "\\"}
append tok "$dquotes,"
}
multiliteral-space {
#assert had_slash 0, multi_dquote ""
- set_tokenType "literalpart"
+ set_tokenType "literalpart"
set tok ","
}
default {
@@ -4462,14 +5186,14 @@ namespace eval tomlish::parse {
. {
set dquotes $multi_dquote
set multi_dquote "" ;#!!
- set had_slash $slash_active
+ 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
+ incr i -1
return 1
}
squote_seq {
@@ -4485,18 +5209,18 @@ namespace eval tomlish::parse {
return 1
}
comment - untyped_value {
- if {$had_slash} {append tok "\\"}
+ if {$had_slash} {append tok "\\"}
append tok $c
}
- string - quotedkey - itablequotedkey {
- if {$had_slash} {append tok "\\"}
+ string - dquotedkey - itablequotedkey {
+ if {$had_slash} {append tok "\\"}
append tok $c
}
stringpart {
- if {$had_slash} {append tok "\\"}
+ if {$had_slash} {append tok "\\"}
append tok $dquotes$c
}
- literal - literalpart - squotedkey - itablesquotedkey {
+ literal - literalpart - squotedkey {
#assert had_slash always 0, multi_dquote ""
append tok $c
}
@@ -4510,18 +5234,22 @@ namespace eval tomlish::parse {
incr i -$backchars
return 1
}
- dottedkey-space {
+ xxxdottedkey-space {
+ incr i -1
+ return 1
+ }
+ dottedkey-space-tail {
incr i -1
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 +5263,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
}
@@ -4545,14 +5273,20 @@ namespace eval tomlish::parse {
multistring-space {
set_tokenType "stringpart"
set tok ""
- if {$had_slash} {append tok "\\"}
+ if {$had_slash} {append tok "\\"}
append tok "$dquotes."
}
multiliteral-space {
set_tokenType "literalpart"
set tok "."
}
- dottedkey-space {
+ XXXdottedkey-space {
+ ### obs?
+ set_tokenType "dotsep"
+ set tok "."
+ return 1
+ }
+ dottedkey-space-tail {
###
set_tokenType "dotsep"
set tok "."
@@ -4576,7 +5310,7 @@ namespace eval tomlish::parse {
newline {
#incomplete newline
set_tokenType "cr"
- incr i -1
+ incr i -1
return 1
}
squote_seq {
@@ -4610,7 +5344,7 @@ namespace eval tomlish::parse {
}
append tok $dquotes$c
}
- string - quotedkey - itablequotedkey {
+ string - dquotedkey - itablequotedkey {
if {$had_slash} { append tok "\\" }
append tok $c
}
@@ -4622,13 +5356,13 @@ namespace eval tomlish::parse {
incr i -2
return 1
} else {
- #split into STRINGPART aaa WS " "
+ #split into STRINGPART aaa WS " "
append tok $dquotes
incr i -1
return 1
}
}
- literal - literalpart - squotedkey - itablesquotedkey {
+ literal - literalpart - squotedkey {
append tok $c
}
whitespace {
@@ -4656,11 +5390,11 @@ 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 {
- set had_slash $slash_active
+ set had_slash $slash_active
set slash_active 0
switch -exact -- $state {
tablename-state {
@@ -4700,7 +5434,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
@@ -4719,7 +5453,7 @@ namespace eval tomlish::parse {
newline {
#incomplete newline
set_tokenType "cr"
- incr i -1
+ incr i -1
return 1
}
startquotesequence {
@@ -4742,10 +5476,11 @@ namespace eval tomlish::parse {
incr i -1
return 1
}
- quotedkey - itablequotedkey - squotedkey - itablesquotedkey {
+ squotedkey {
append tok $c
}
- string - comment - whitespace {
+ dquotedkey - string - comment - whitespace {
+ #REVIEW
append tok $c
}
stringpart {
@@ -4756,7 +5491,7 @@ namespace eval tomlish::parse {
incr i -2
return 1
} else {
- #split into STRINGPART aaa WS " "
+ #split into STRINGPART aaa WS " "
append tok $dquotes
incr i -1
return 1
@@ -4775,11 +5510,11 @@ 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 {
- set had_slash $slash_active
+ set had_slash $slash_active
if {$slash_active} {
set slash_active 0
}
@@ -4787,11 +5522,11 @@ namespace eval tomlish::parse {
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_tokenType tablename
set tok $c
}
tablearrayname-state {
- set_tokenType tablearrayname
+ set_tokenType tablearrayname
set tok $c
}
multistring-space {
@@ -4841,7 +5576,7 @@ namespace eval tomlish::parse {
return 1
}
}
- } else {
+ } else {
switch -exact -- $state {
multiliteral-space {
set_tokenType "literalpart"
@@ -4866,7 +5601,7 @@ namespace eval tomlish::parse {
newline {
#incomplete newline
set_tokenType "cr"
- incr i -1
+ incr i -1
return 1
}
squote_seq {
@@ -4901,7 +5636,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,16 +5662,16 @@ 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 {
+ XXXcurly-syntax {
puts stderr "curly-syntax - review"
if {[tomlish::utils::is_barekey $c]} {
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 {
@@ -4961,11 +5696,13 @@ namespace eval tomlish::parse {
set tok $c
}
dottedkey-space {
- set_tokenType barekey
+ set_tokenType barekey
set tok $c
}
default {
- tomlish::log::debug "- tokloop char '$c' setting to untyped_value while state:$state"
+ #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
}
@@ -4973,9 +5710,9 @@ namespace eval tomlish::parse {
}
}
}
-
+
}
-
+
#run out of characters (eof)
if {[tcl::string::length $tokenType]} {
#check for invalid ending tokens
@@ -4988,7 +5725,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
@@ -5002,18 +5739,33 @@ namespace eval tomlish::parse {
set toklen [tcl::string::length $tok]
switch -- $toklen {
1 {
- #invalid eof with open literal
- error "eof reached without closing single quote for string literal. [tomlish::parse::report_line]"
+ #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_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
@@ -5029,19 +5781,81 @@ 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 <tag> value <whatever>} 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]
+ #[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 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
@@ -5051,7 +5865,7 @@ tcl::namespace::eval tomlish::app {
#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]
+ set toml [read stdin]
}]} {
exit 2 ;#read error
}
@@ -5076,7 +5890,7 @@ tcl::namespace::eval tomlish::app {
set opts [dict merge [dict create] $args]
fconfigure stdin -translation binary
if {[catch {
- set json [read stdin]
+ set json [read stdin]
}]} {
exit 2 ;#read error
}
@@ -5087,7 +5901,7 @@ tcl::namespace::eval tomlish::app {
exit 1
}
puts -nonewline stdout $toml
- exit 0
+ exit 0
}
proc test {args} {
@@ -5111,7 +5925,7 @@ proc ::tomlish::appnames {} {
lappend applist [namespace tail $cmd]
}
return $applist
-}
+}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@@ -5122,14 +5936,14 @@ namespace eval tomlish::lib {
namespace path [namespace parent]
#*** !doctools
#[subsection {Namespace tomlish::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
#}
@@ -5140,46 +5954,46 @@ namespace eval 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 <appname> 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
- }
+ puts stderr "argc: $argc args: $argv"
+
+ if {($argc == 1)} {
+ if {[tcl::string::tolower $argv] in {help -help h -h}} {
+ puts stdout "Usage: -app <appname> 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
+## Ready
package provide tomlish [namespace eval tomlish {
variable pkg tomlish
variable version
- set version 1.1.1
+ set version 1.1.3
}]
return