From 9201234c4ff98fe5c54e280bf2ffbcd0f3944cd4 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Mon, 28 Apr 2025 13:09:12 +1000 Subject: [PATCH] add previous updates to bootsupport and project_layouts and common vfs --- .../modules/punk/aliascore-0.1.0.tm | 67 +- src/bootsupport/modules/punk/ansi-0.1.1.tm | 252 +++- src/bootsupport/modules/punk/args-0.1.4.tm | 31 +- src/bootsupport/modules/punk/config-0.1.tm | 274 +++- src/bootsupport/modules/punk/console-0.1.1.tm | 6 +- src/bootsupport/modules/punk/mod-0.1.tm | 6 +- src/bootsupport/modules/punk/ns-0.1.0.tm | 26 +- .../modules/punk/repl/codethread-0.1.1.tm | 6 +- src/bootsupport/modules/shellfilter-0.1.9.tm | 157 +- src/bootsupport/modules/test/tomlish-1.1.5.tm | Bin 53903 -> 56588 bytes src/bootsupport/modules/textblock-0.1.3.tm | 2 +- src/bootsupport/modules/tomlish-1.1.6.tm | 1292 ++++++++++++++-- .../modules/punk/aliascore-0.1.0.tm | 67 +- .../bootsupport/modules/punk/ansi-0.1.1.tm | 252 +++- .../bootsupport/modules/punk/args-0.1.4.tm | 31 +- .../bootsupport/modules/punk/config-0.1.tm | 274 +++- .../bootsupport/modules/punk/console-0.1.1.tm | 6 +- .../src/bootsupport/modules/punk/mod-0.1.tm | 6 +- .../src/bootsupport/modules/punk/ns-0.1.0.tm | 26 +- .../modules/punk/repl/codethread-0.1.1.tm | 6 +- .../bootsupport/modules/shellfilter-0.1.9.tm | 157 +- .../bootsupport/modules/test/tomlish-1.1.5.tm | Bin 53903 -> 56588 bytes .../bootsupport/modules/textblock-0.1.3.tm | 2 +- .../src/bootsupport/modules/tomlish-1.1.6.tm | 1292 ++++++++++++++-- .../modules/punk/aliascore-0.1.0.tm | 67 +- .../bootsupport/modules/punk/ansi-0.1.1.tm | 252 +++- .../bootsupport/modules/punk/args-0.1.4.tm | 31 +- .../bootsupport/modules/punk/config-0.1.tm | 274 +++- .../bootsupport/modules/punk/console-0.1.1.tm | 6 +- .../src/bootsupport/modules/punk/mod-0.1.tm | 6 +- .../src/bootsupport/modules/punk/ns-0.1.0.tm | 26 +- .../modules/punk/repl/codethread-0.1.1.tm | 6 +- .../bootsupport/modules/shellfilter-0.1.9.tm | 157 +- .../bootsupport/modules/test/tomlish-1.1.5.tm | Bin 53903 -> 56588 bytes .../bootsupport/modules/textblock-0.1.3.tm | 2 +- .../src/bootsupport/modules/tomlish-1.1.6.tm | 1292 ++++++++++++++-- .../{dictn-0.1.1.tm => dictn-0.1.2.tm} | 35 +- .../_vfscommon.vfs/modules/modpod-0.1.3.tm | 704 +++++++++ src/vfs/_vfscommon.vfs/modules/punk-0.1.tm | 5 +- .../modules/punk/aliascore-0.1.0.tm | 67 +- .../_vfscommon.vfs/modules/punk/ansi-0.1.1.tm | 252 +++- .../_vfscommon.vfs/modules/punk/args-0.1.4.tm | 31 +- .../modules/punk/args/tclcore-0.1.0.tm | 127 +- .../modules/punk/basictelnet-0.1.0.tm | 13 + .../_vfscommon.vfs/modules/punk/config-0.1.tm | 276 +++- .../modules/punk/console-0.1.1.tm | 6 +- .../_vfscommon.vfs/modules/punk/mod-0.1.tm | 6 +- .../modules/punk/netbox-0.1.0.tm | 31 +- .../_vfscommon.vfs/modules/punk/ns-0.1.0.tm | 26 +- .../_vfscommon.vfs/modules/punk/repl-0.1.1.tm | 48 +- .../modules/punk/repl/codethread-0.1.1.tm | 6 +- .../modules/shellfilter-0.1.9.tm | 157 +- .../_vfscommon.vfs/modules/shellrun-0.1.1.tm | 12 +- .../modules/test/tomlish-1.1.5.tm | Bin 53903 -> 56588 bytes .../_vfscommon.vfs/modules/textblock-0.1.3.tm | 2 +- .../_vfscommon.vfs/modules/tomlish-1.1.6.tm | 1331 +++++++++++++++-- 56 files changed, 8301 insertions(+), 1191 deletions(-) rename src/vfs/_vfscommon.vfs/modules/{dictn-0.1.1.tm => dictn-0.1.2.tm} (91%) create mode 100644 src/vfs/_vfscommon.vfs/modules/modpod-0.1.3.tm diff --git a/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 5b45b2bc..c7207cc0 100644 --- a/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -103,7 +103,9 @@ tcl::namespace::eval punk::aliascore { #use absolute ns ie must be prefixed with :: #single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased - #functions must be in export list of their source namespace + #functions should generally be covered by one of the export patterns of their source namespace + # - if they are not - e.g (separately loaded ensemble command ?) + # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. set aliases [tcl::dict::create\ val ::punk::pipe::val\ aliases ::punk::lib::aliases\ @@ -122,8 +124,8 @@ tcl::namespace::eval punk::aliascore { stripansi ::punk::ansi::ansistrip\ ansiwrap ::punk::ansi::ansiwrap\ colour ::punk::console::colour\ - ansi ::punk::console::ansi\ color ::punk::console::colour\ + ansi ::punk::console::ansi\ a? ::punk::console::code_a?\ A? {::punk::console::code_a? forcecolor}\ a+ ::punk::console::code_a+\ @@ -132,6 +134,7 @@ tcl::namespace::eval punk::aliascore { A {::punk::console::code_a forcecolour}\ smcup ::punk::console::enable_alt_screen\ rmcup ::punk::console::disable_alt_screen\ + config ::punk::config\ ] #*** !doctools @@ -153,6 +156,35 @@ tcl::namespace::eval punk::aliascore { # return "ok" #} + proc _is_exported {ns cmd} { + set exports [::tcl::namespace::eval $ns [list namespace export]] + set is_exported 0 + foreach p $exports { + if {[string match $p $cmd]} { + set is_exported 1 + break + } + } + return $is_exported + } + + #_nsprefix accepts entire command - not just an existing namespace for which we want the parent + proc _nsprefix {{nspath {}}} { + #maintenance: from punk::ns::nsprefix - (without unnecessary nstail) + #normalize the common case of :::: + set nspath [string map {:::: ::} $nspath] + set rawprefix [string range $nspath 0 end-[string length [namespace tail $nspath]]] + if {$rawprefix eq "::"} { + return $rawprefix + } else { + if {[string match *:: $rawprefix]} { + return [string range $rawprefix 0 end-2] + } else { + return $rawprefix + } + } + } + #todo - options as to whether we should raise an error if collisions found, undo aliases etc? proc init {args} { set defaults {-force 0} @@ -195,6 +227,7 @@ tcl::namespace::eval punk::aliascore { error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" } + set failed [list] set tempns ::temp_[info cmdcount] ;#temp ns for renames dict for {a cmd} $aliases { #puts "aliascore $a -> $cmd" @@ -206,16 +239,36 @@ tcl::namespace::eval punk::aliascore { } else { if {[tcl::info::commands $cmd] ne ""} { #todo - ensure exported? noclobber? - if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { + set container_ns [_nsprefix $cmd] + set cmdtail [tcl::namespace::tail $cmd] + set was_exported 1 ;#assumption + if {![_is_exported $container_ns $cmdtail]} { + set was_exported 0 + set existing_exports [tcl::namespace::eval $container_ns [list ::namespace export]] + tcl::namespace::eval $container_ns [list ::namespace export $cmdtail] + } + if {[tcl::namespace::tail $a] eq $cmdtail} { #puts stderr "importing $cmd" - tcl::namespace::eval :: [list namespace import $cmd] + try { + tcl::namespace::eval :: [list ::namespace import $cmd] + } trap {} {emsg eopts} { + lappend failed [list alias $a target $cmd errormsg $emsg] + } } else { #target command name differs from exported name #e.g stripansi -> punk::ansi::ansistrip #import and rename #puts stderr "importing $cmd (with rename to ::$a)" - tcl::namespace::eval $tempns [list namespace import $cmd] - catch {rename ${tempns}::[namespace tail $cmd] ::$a} + try { + tcl::namespace::eval $tempns [list ::namespace import $cmd] + } trap {} {emsg eopst} { + lappend failed [list alias $a target $cmd errormsg $emsg] + } + catch {rename ${tempns}::$cmdtail ::$a} + } + #restore original exports + if {!$was_exported} { + tcl::namespace::eval $container_ns [list ::namespace export -clear {*}$existing_exports] } } else { interp alias {} $a {} {*}$cmd @@ -223,7 +276,7 @@ tcl::namespace::eval punk::aliascore { } } #tcl::namespace::delete $tempns - return [dict create aliases [dict keys $aliases] unchanged $ignore_aliases changed $conflicts] + return [dict create aliases [dict keys $aliases] existing $existing ignored $ignore_aliases changed $conflicts failed $failed] } diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index 61a454fa..fcbf6ada 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3357,9 +3357,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend PUNKARGS [list { @id -id ::punk::ansi::ansiwrap @cmd -name punk::ansi::ansiwrap -help\ - "Wrap a string with ANSI codes from + {Wrap a string with ANSI codes from supplied codelist(s) followed by trailing - ANSI reset. + ANSI reset. The wrapping is done such that + after every reset in the supplied text, the + default goes back to the supplied codelist. + e.g1 in the following + ansiwrap red bold "rrr[a+ green]ggg[a]rrr" + both strings rrr will be red & bold + + e.g2 bolding and underlining specific text whilst dimming the rest + ansiwrap dim [string map [list test [ansiwrap bold underline test]] "A test string"] + + e.g3 reverse render a complex ansi substring + ansiwrap reverse [textblock::periodic] Codes are numbers or strings as indicated in the output of the colour information @@ -3372,41 +3383,172 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu For finer control use the a+ and a functions eg - set x \"[a+ red]text [a+ bold]etc[a]\" - " + set x "[a+ red]text [a+ bold]etc[a]" + } @leaders -min 0 -max -1 codelist -multiple 1 -default {} -type list -help\ "ANSI names/ints as understood by 'a?' (Not actual ANSI as output by a+) These can be supplied individually or as a list or lists" + @opts + -rawansi -type ansi -default "" + -resetcodes -type list -default {reset} + -rawresets -type ansi -default "" + -fullcodemerge -type boolean -default 0 -help\ + "experimental" + -overridecodes -type list -default {} @values -min 1 -max 1 text -type string -help\ "String to wrap with ANSI (SGR)" }] - #proc ansiwrap {codes text} { - # return [a {*}$codes]$text[a] - #} - proc ansiwrap2 {args} { - set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] - set codelists [dict get $argd leaders codelist] - set text [dict get $argd values text] - set codes [concat {*}$codelists] ;#flatten - return [a {*}$codes]$text[a] - } proc ansiwrap {args} { if {[llength $args] < 1} { - #minimal args parsing - unhappy path only + #throw to args::parse to get friendly error/usage display punk::args::parse $args withid ::punk::ansi::ansiwrap return } - set text [lindex $args end] - set codelists [lrange $args 0 end-1] + #we know there are no valid codes that start with - + if {[lsearch [lrange $args 0 end-1] -*] == -1} { + #no opts + set text [lindex $args end] + set codelists [lrange $args 0 end-1] + set R [a] ;#plain ansi reset + set rawansi "" + set rawresets "" + set fullmerge 0 + set overrides "" + } else { + set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] + lassign [dict values $argd] leaders opts values received solos + set codelists [dict get $leaders codelist] + set text [dict get $values text] + set rawansi [dict get $opts -rawansi] + set R [a+ {*}[dict get $opts -resetcodes]] + set rawresets [dict get $opts -rawresets] + set fullmerge [dict get $opts -fullcodemerge] + set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]] + } + + #note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence. + #there can be SGR unmergeables (due to enhanced underlines) as well as non SGR codes set codes [concat {*}$codelists] ;#flatten - return [a {*}$codes]$text[a] - } + set base [a+ {*}$codes] + if {$rawansi ne ""} { + set rawcodes [punk::ansi::ta::get_codes_single $rawansi] ;#caller may have supplied as [a+ xxx][a+ yyy] + if {$fullmerge} { + set base [punk::ansi::codetype::sgr_merge [list $base {*}$rawcodes]] + } else { + set base [punk::ansi::codetype::sgr_merge_singles [list $base {*}$rawcodes]] + } + } + if {$rawresets ne ""} { + set rawresetcodes [punk::ansi::ta::get_codes_single $rawresets] + if {$fullmerge} { + set R [punk::ansi::codetype::sgr_merge [list $R {*}$rawresetcodes]] + } else { + set R [punk::ansi::codetype::sgr_merge_singles [list $R {*}$rawresetcodes]] + } + } + set codestack [list] + if {[punk::ansi::ta::detect $text]} { + set emit "" + set parts [punk::ansi::ta::split_codes $text] + foreach {pt code} $parts { + switch -- [llength $codestack] { + 0 { + append emit $base$pt$R + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { + append emit $base$pt$R + set codestack [list] + } else { + #append emit [lindex $o_codestack 0]$pt + if {$fullmerge} { + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + } else { + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + } + } + } + default { + if {$fullmerge} { + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + } else { + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + } + } + } + #parts ends on a pt - last code always empty string + if {$code ne ""} { + set c1c2 [tcl::string::range $code 0 1] + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3] + switch -- $leadernorm { + 7CSI - 8CSI { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #todo - make caching is_sgr method + set dup_posns [lsearch -all -exact $codestack $code] + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set o_gx_state on + } + "B" { + set o_gx_state off + } + } + } + default { + #other ansi codes + } + } + append emit $code + } + } + return $emit$R + } else { + return $base$text$R + } + } + proc ansiwrap_naive {codes text} { + return [a_ {*}$codes]$text[a] + } + + #a silly trick... temporary? probably - todo - tests and work on sgr_merge + sgr_merge_singles before relying on this + #when we use sgr_merge_singles on a 'single' containing a non SGR code e.g [5h (inverse) it puts this code at the end of the list + #furthermore - it carries any SGR codes along with it (Can/should we rely on this behaviour??? probably not) REVIEW + #P% ansistring VIEW $s1 + #- ␛[31m␛[?5h + #P% ansistring VIEW [punk::ansi::codetype::sgr_merge_singles [list $s1 [a+ cyan]]] + #- ␛[36m␛[31m␛[?5h + #P% ansistring VIEW [punk::ansi::codetype::sgr_merge [list $s1 [a+ cyan]]] + #- ␛[36m␛[?5h + #we can use this trick to override background and/or foreground colours using ansiwrap - which uses sgr_merge_singles + #Note - this trick is not composable - e.g ansioverride Red [ansiioverride Green [textblock::periodic]] doesn't work as expected. + proc ansioverride2 {args} { + set text [lindex $args end] + set codes [lrange $args 0 end-1] + ansiwrap {*}$codes -rawansi [punk::ansi::enable_inverse] -rawresets [punk::ansi::disable_inverse] $text + } + proc ansireverse {text} { + ansioverride2 normal reverse $text + } proc get_code_name {code} { #*** !doctools @@ -4491,6 +4633,77 @@ tcl::namespace::eval punk::ansi { return 0 } } + + #e.g has_any_effective $str bg fg + proc has_any_effective {str args} { + set singlecodes [punk::ansi::ta::get_codes_single $str] + set mergeinfo [punk::ansi::codetype::sgr_merge_singles $singlecodes -info 1] + foreach t $args { + switch -- $t { + sgr - unmergeable - othercodes { + if {[dict get $mergeinfo $t] ne ""} { + return 1 + } + } + intensity - italic - underline - underextended - blink - reverse - hide - strike - font - gothic - doubleunderline + - proportional - frame_or_circle - ideogram_underline - ideogram_doubleunderline - ideogram_clear - overline - underlinecolour - superscript - subscript + - nosupersub - fg - bg { + if {[dict get $mergeinfo codestate $t] ne ""} { + return 1 + } + } + bold { + if {[dict get $mergeinfo codestate intensity] eq "1"} { + return 1 + } + } + dim { + if {[dict get $mergeinfo codestate intensity] eq "2"} { + return 1 + } + } + default { + error "punk::ansi::ta::has_any_effective invalid type '$t' specified" + } + } + } + return 0 + } + proc has_all_effective {str args} { + set singlecodes [punk::ansi::ta::get_codes_single $str] + set mergeinfo [punk::ansi::codetype::sgr_merge_singles $singlecodes -info 1] + foreach t $args { + switch -- $t { + sgr - unmergeable - othercodes { + if {[dict get $mergeinfo $t] eq ""} { + return 0 + } + } + intensity - italic - underline - underextended - blink - reverse - hide - strike - font - gothic - doubleunderline + - proportional - frame_or_circle - ideogram_underline - ideogram_doubleunderline - ideogram_clear - overline - underlinecolour - superscript - subscript + - nosupersub - fg - bg { + if {[dict get $mergeinfo codestate $t] eq ""} { + return 0 + } + } + bold { + if {[dict get $mergeinfo codestate intensity] ne "1"} { + return 0 + } + } + dim { + if {[dict get $mergeinfo codestate intensity] ne "2"} { + return 0 + } + } + default { + error "punk::ansi::ta::has_any_effective invalid type '$t' specified" + } + } + } + return 1 + } + proc is_gx {code} { #g0 {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} #g1 {(?:\x1b\)0)(?:(?!\x1b\)B).)*\x1b\)B} @@ -4513,6 +4726,7 @@ tcl::namespace::eval punk::ansi { set codestate_empty [tcl::dict::create] tcl::dict::set codestate_empty rst "" ;#0 (or empty) tcl::dict::set codestate_empty intensity "" ;#1 bold, 2 dim, 22 normal + tcl::dict::set codestate_empty shadowed "" ; tcl::dict::set codestate_empty italic "" ;#3 on 23 off tcl::dict::set codestate_empty underline "" ;#4 on 24 off diff --git a/src/bootsupport/modules/punk/args-0.1.4.tm b/src/bootsupport/modules/punk/args-0.1.4.tm index 95d5c702..e1256fe4 100644 --- a/src/bootsupport/modules/punk/args-0.1.4.tm +++ b/src/bootsupport/modules/punk/args-0.1.4.tm @@ -3226,7 +3226,36 @@ tcl::namespace::eval punk::args { form1: parse $arglist ?-flag val?... withid $id form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define" + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " @form -form {withid withdef} @leaders -min 1 -max 1 arglist -type list -optional 0 -help\ diff --git a/src/bootsupport/modules/punk/config-0.1.tm b/src/bootsupport/modules/punk/config-0.1.tm index 5532cb80..f2f85349 100644 --- a/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/bootsupport/modules/punk/config-0.1.tm @@ -1,23 +1,109 @@ tcl::namespace::eval punk::config { - variable loaded - variable startup ;#include env overrides - variable running + variable configdata [dict create] ;#key on config names. At least default, startup, running + + #variable startup ;#include env overrides + #variable running + variable punk_env_vars variable other_env_vars variable vars namespace export {[a-z]*} + namespace ensemble create + namespace eval punk {namespace export config} + + proc _homedir {} { + if {[info exists ::env(HOME)]} { + set home [file normalize $::env(HOME)] + } else { + #not available on 8.6? ok will error out here. + set home [file tildeexpand ~] + } + return $home + } + + lappend PUNKARGS [list { + @id -id ::punk::config::dir + @cmd -name punk::config::dir -help\ + "Get the path for the default config folder + Config files are in toml format. + + The XDG_CONFIG_HOME env var is the preferred + choice of location. + A folder under the user's home directory, + at .config/punk/shell is chosen if + XDG_CONFIG_HOME is not configured. + " + @leaders -min 0 -max 0 + @opts + -quiet -type none -help\ + "Suppress warning given when the folder does + not yet exist" + @values -min 0 -max 0 + }] + proc dir {args} { + if {"-quiet" in $args} { + set be_quiet [dict exists $received -quiet] + } + + set was_noisy 0 + + set config_home [punk::config::configure running xdg_config_home] + + set config_dir [file join $config_home punk shell] + + if {!$be_quiet && ![file exists $config_dir]} { + set msg "punk::shell data storage folder at $config_dir does not yet exist." + puts stderr $msg + set was_noisy 1 + } + + if {!$be_quiet && $was_noisy} { + puts stderr "punk::config::dir - call with -quiet option to suppress these messages" + } + return $config_dir + + #if {[info exists ::env(XDG_CONFIG_HOME)]} { + # set config_home $::env(XDG_CONFIG_HOME) + #} else { + # set config_home [file join [_homedir] .config] + # if {!$be_quiet} { + # puts stderr "Environment variable XDG_CONFIG_HOME does not exist - consider setting it if $config_home is not a suitable location" + # set was_noisy 1 + # } + #} + #if {!$be_quiet && ![file exists $config_home]} { + # #parent folder for 'punk' config dir doesn't exist + # set msg "configuration location (XDG_CONFIG_HOME or ~/.config) $config_home does not yet exist" + # append msg \n " - please create it and/or set XDG_CONFIG_HOME env var." + # puts stderr $msg + # set was_noisy 1 + #} + #set config_dir [file join $config_home punk shell] + #if {!$be_quiet && ![file exists $config_dir]} { + # set msg "punk::shell data storage folder at $config_dir does not yet exist." + # append msg \n " It will be created if api_context_save is called without specifying an alternate location." + # puts stderr $msg + # set was_noisy 1 + #} + #if {!$be_quiet && $was_noisy} { + # puts stderr "punk::config::dir - call with -quiet option to suppress these messages" + #} + #return [file join $configdir config.toml] + } #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 configdata + + #variable defaults + #variable startup + #variable running variable punk_env_vars variable punk_env_vars_config variable other_env_vars @@ -108,12 +194,14 @@ tcl::namespace::eval punk::config { #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)]} { + #Typical existing/default value for env(APPDATA) on windows is c:\Users\\AppData\Roaming 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)]} { + #Typical existing/default value for env(APPDATA) on windows is c:\Users\\AppData\Local + set default_xdg_data_home $::env(LOCALAPPDATA) set default_xdg_cache_home $::env(LOCALAPPDATA) set default_xdg_state_home $::env(LOCALAPPDATA) } @@ -133,10 +221,10 @@ tcl::namespace::eval punk::config { } } - set defaults [dict create\ + dict set configdata defaults [dict create\ apps $default_apps\ - config ""\ - configset ".punkshell"\ + config "startup"\ + configset "main"\ scriptlib $default_scriptlib\ color_stdout $default_color_stdout\ color_stdout_repl $default_color_stdout_repl\ @@ -160,7 +248,7 @@ tcl::namespace::eval punk::config { posh_themes_path ""\ ] - set startup $defaults + dict set configdata startup [dict get $configdata 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 @@ -219,9 +307,9 @@ tcl::namespace::eval punk::config { lappend final $p } } - tcl::dict::set startup $varname $final + tcl::dict::set configdata startup $varname $final } else { - tcl::dict::set startup $varname $f + tcl::dict::set configdata startup $varname $f } } } @@ -273,29 +361,44 @@ tcl::namespace::eval punk::config { lappend final $p } } - tcl::dict::set startup $varname $final + tcl::dict::set configdata startup $varname $final } else { - tcl::dict::set startup $varname $f + tcl::dict::set configdata startup $varname $f } } } } + set config_home [dict get $configdata startup xdg_config_home] + + if {![file exists $config_home]} { + puts stderr "punk::config::init creating punk shell config dir: [dir]" + puts stderr "(todo)" + } + + set configset [dict get $configdata defaults configset] + set config [dict get $configdata defaults config] + + set startupfile [file join $config_home $configset $config.toml] + if {![file exists $startupfile]} { + puts stderr "punk::config::init creating punk shell config file: $config for configset: $configset" + puts stderr "(todo)" + } #unset -nocomplain vars #todo set running [tcl::dict::create] - set running [tcl::dict::merge $running $startup] + dict set configdata running [tcl::dict::merge $running [dict get $configdata startup]] } - init #todo proc Apply {config} { + variable configdata puts stderr "punk::config::Apply partially implemented" set configname [string map {-config ""} $config] if {$configname in {startup running}} { - upvar ::punk::config::$configname applyconfig + set applyconfig [dict get $configdata $configname] if {[dict exists $applyconfig auto_noexec]} { set auto [dict get $applyconfig auto_noexec] @@ -315,67 +418,128 @@ tcl::namespace::eval punk::config { } return "apply done" } - Apply startup #todo - consider how to divide up settings, categories, 'devices', decks etc proc get_running_global {varname} { - variable running + variable configdata + set running [dict get $configdata 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 + variable configdata + set startup [dict get $configdata 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 + lappend PUNKARGS [list { + @id -id ::punk::config::get + @cmd -name punk::config::get -help\ + "Get configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + whichconfig -type string -choices {config startup-configuration running-configuration} + @values -min 0 -max -1 + globkey -type string -default * -optional 1 -multiple 1 + }] + proc get {args} { + set argd [punk::args::parse $args withid ::punk::config::get] + lassign [dict values $argd] leaders opts values received solos + set whichconfig [dict get $leaders whichconfig] + set globs [dict get $values globkey] ;#list + + variable configdata + switch -- $whichconfig { - config - startup - startup-config - startup-configuration { + config - startup-configuration { + #review 'config' ?? #show *startup* config - different behaviour may be confusing to those used to router startup and running configs - set configdata $startup + set configrecords [dict get $configdata startup] } - running - running-config - running-configuration { - set configdata $running + running-configuration { + set configrecords [dict get $configdata running] } default { error "Unknown config name '$whichconfig' - try startup or running" } } - if {$globfor eq "*"} { - return $configdata + if {"*" in $globs} { + return $configrecords } else { - set keys [dict keys $configdata [string tolower $globfor]] + set keys [list] + foreach g $globs { + lappend keys {*}[dict keys $configrecords [string tolower $g]] ;#review tolower? + } + set filtered [dict create] foreach k $keys { - dict set filtered $k [dict get $configdata $k] + dict set filtered $k [dict get $configrecords $k] } return $filtered } } + lappend PUNKARGS [list { + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ + "Get/set configuration values from a config" + @leaders -min 1 -max 1 + whichconfig -type string -choices {defaults startup-configuration running-configuration} + @values -min 0 -max 2 + key -type string -optional 1 + newvalue -optional 1 + }] 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::parse $args withid ::punk::config::configure] + lassign [dict values $argd] leaders opts values received solos + set whichconfig [dict get $argd leaders whichconfig] + variable configdata + if {"running" ni [dict keys $configdata]} { + init + Apply startup } - set argd [punk::args::get_dict $argdef $args] - return "unimplemented - $argd" + switch -- $whichconfig { + defaults { + set configrecords [dict get $configdata defaults] + } + startup-configuration { + set configrecords [dict get $configdata startup] + } + running-configuration { + set configrecords [dict get $configdata running] + } + } + if {![dict exists $received key]} { + return $configrecords + } + set key [dict get $values key] + if {![dict exists $received newvalue]} { + return [dict get $configrecords $key] + } + error "setting value not implemented" } - proc show {whichconfig {globfor *}} { + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::config::show + @cmd -name punk::config::get -help\ + "Display configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + }\ + {${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ + "@values -min 0 -max -1"\ + {${[punk::args::resolved_def -types values ::punk::config::get]}}\ + ] + proc show {args} { #todo - tables for console - set configdata [punk::config::get $whichconfig $globfor] - return [punk::lib::showdict $configdata] + set configrecords [punk::config::get {*}$args] + return [punk::lib::showdict $configrecords] } @@ -459,27 +623,35 @@ tcl::namespace::eval punk::config { ::tcl::namespace::eval punk::config { #todo - something better - 'previous' rather than reverting to startup proc channelcolors {{onoff {}}} { - variable running - variable startup + variable configdata + #variable running + #variable startup if {![string length $onoff]} { - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + return [list stdout [dict get $configdata running color_stdout] stderr [dict get $configdata 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] + dict set configdata running color_stdout [dict get $startup color_stdout] + dict set configdata running color_stderr [dict get $startup color_stderr] } else { - dict set running color_stdout "" - dict set running color_stderr "" + dict set configdata running color_stdout "" + dict set configdata running color_stderr "" } } - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + return [list stdout [dict get $configdata running color_stdout] stderr [dict get $configdata running color_stderr]] } + } +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::config +} + + package provide punk::config [tcl::namespace::eval punk::config { variable version set version 0.1 diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index a3f5d95c..19d9d7e4 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -584,10 +584,10 @@ namespace eval punk::console { channel's response to a query placed on the output channel. Usually this means a write to stdout with a response on stdin. - This function uses a 'chan event' read handler function + This function uses a 'chan event' read handler function ::punk::console::internal::ansi_response_handler_regex to read the input channel character by character to ensure it - doesn't overconsume input. + doesn't overconsume input. It can run cooperatively with the punk::repl stdin reader or other readers if done carefully. @@ -609,7 +609,7 @@ namespace eval punk::console { "dict with keys prefix,response,payload,all" } -help\ "Return format" - + -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" -expected_ms -default 100 -type integer -help\ diff --git a/src/bootsupport/modules/punk/mod-0.1.tm b/src/bootsupport/modules/punk/mod-0.1.tm index 26ed2f2e..8f1ba266 100644 --- a/src/bootsupport/modules/punk/mod-0.1.tm +++ b/src/bootsupport/modules/punk/mod-0.1.tm @@ -33,8 +33,7 @@ namespace eval punk::mod::cli { return $basehelp } proc getraw {appname} { - upvar ::punk::config::running running_config - set app_folders [dict get $running_config apps] + set app_folders [punk::config::configure running apps] #todo search each app folder set bases [::list] set versions [::list] @@ -86,8 +85,7 @@ namespace eval punk::mod::cli { } proc list {{glob *}} { - upvar ::punk::config::running running_config - set apps_folder [dict get $running_config apps] + set apps_folder [punk::config::configure running apps] if {[file exists $apps_folder]} { if {[file exists $apps_folder/$glob]} { #tailcall source $apps_folder/$glob/main.tcl diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm index 4eb6526d..b89bc021 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -375,7 +375,9 @@ tcl::namespace::eval punk::ns { #This is because :x (or even just : ) can in theory be the name of a command and we may need to see it (although it is not a good idea) #and a namespace can exist with leading colon - but is even worse - as default Tcl commands will misreport e.g namespace current within namespace eval #The view is taken that a namespace with leading/trailing colons is so error-prone that even introspection is unreliable so we will rule that out. - # + # + #nsprefix is *somewhat* like 'namespace parent' execept that it is string based - ie no requirement for the namespaces to actually exist + # - this is an important usecase even if the handling of 'unwise' command names isn't so critical. proc nsprefix {{nspath ""}} { #normalize the common case of :::: set nspath [string map {:::: ::} $nspath] @@ -394,10 +396,12 @@ tcl::namespace::eval punk::ns { #namespace tail which handles :::cmd ::x:::y ::x:::/y etc in a specific manner for string processing #review - consider making -strict raise an error for unexpected sequences such as :::: or any situation with more than 2 colons together. + #This is only necessary in the context of requirement to browse namespaces with 'unwisely' named commands + #For most purposes 'namespace tail' is fine. proc nstail {nspath args} { #normalize the common case of :::: set nspath [string map {:::: ::} $nspath] - set mapped [string map {:: \u0FFF} $nspath] + set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] set defaults [list -strict 0] @@ -2018,7 +2022,7 @@ tcl::namespace::eval punk::ns { } proc arginfo {args} { lassign [dict values [punk::args::parse $args withid ::punk::ns::arginfo]] leaders opts values received - + set nscaller [uplevel 1 [list ::namespace current]] #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. if {![dict exists $received -scheme]} { @@ -2081,16 +2085,18 @@ tcl::namespace::eval punk::ns { } } else { #namespace as relative to current doesn't seem to exist - #Tcl would also attempt to resolve as global + #Tcl would also attempt to resolve as global - #set numvals [expr {[llength $queryargs]+1}] + #set numvals [expr {[llength $queryargs]+1}] ##puts "THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]] - return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] + if {$nscaller ne "::"} { + return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] + } + + set origin $querycommand + set resolved $querycommand - #set origin $querycommand - #set resolved $querycommand - } } } @@ -2098,7 +2104,7 @@ tcl::namespace::eval punk::ns { #check for a direct match first if {[info commands ::punk::args::id_exists] ne ""} { if {![llength $queryargs]} { - punk::args::update_definitions [list [namespace qualifiers $origin]] + punk::args::update_definitions [list [namespace qualifiers $origin]] if {[punk::args::id_exists $origin]} { return [uplevel 1 [list punk::args::usage {*}$opts $origin]] } diff --git a/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm b/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm index a64eef0f..7bf8306e 100644 --- a/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm +++ b/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm @@ -175,13 +175,13 @@ tcl::namespace::eval punk::repl::codethread { set outstack [list] set errstack [list] - upvar ::punk::config::running running_config - if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { + set config_running [::punk::config::configure running] + if {[string length [dict get $config_running color_stdout_repl]] && [interp eval code punk::console::colour]} { lappend outstack [interp eval code [list ::shellfilter::stack add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] } lappend outstack [interp eval code [list ::shellfilter::stack add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] - if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { + if {[string length [dict get $config_running color_stderr_repl]] && [interp eval code punk::console::colour]} { lappend errstack [interp eval code [list ::shellfilter::stack add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] # #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] } diff --git a/src/bootsupport/modules/shellfilter-0.1.9.tm b/src/bootsupport/modules/shellfilter-0.1.9.tm index 92b214d8..73ea752c 100644 --- a/src/bootsupport/modules/shellfilter-0.1.9.tm +++ b/src/bootsupport/modules/shellfilter-0.1.9.tm @@ -674,6 +674,9 @@ namespace eval shellfilter::chan { #todo - track when in sixel,iterm,kitty graphics data - can be very large method Trackcodes {chunk} { + #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) + #e.g [a+ reset reset] (0;0m vs 0;m) + #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" set buf $o_buffered$chunk set emit "" @@ -686,12 +689,29 @@ namespace eval shellfilter::chan { #process all pt/code pairs except for trailing pt foreach {pt code} [lrange $parts 0 end-1] { #puts "<==[ansistring VIEW -lf 1 $pt]==>" - if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - append emit $o_do_colour$pt$o_do_normal - #append emit $pt - } else { - append emit $pt + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$pt + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt + } } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # append emit $o_do_colour$pt$o_do_normal + # #append emit $pt + #} else { + # append emit $pt + #} set c1c2 [tcl::string::range $code 0 1] set leadernorm [tcl::string::range [tcl::string::map [list\ @@ -732,7 +752,7 @@ namespace eval shellfilter::chan { } - set trailing_pt [lindex $parts end] + set trailing_pt [lindex $parts end] if {[string first \x1b $trailing_pt] >= 0} { #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" #may not be plaintext after all @@ -740,15 +760,32 @@ namespace eval shellfilter::chan { #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" } else { #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] - if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { - append emit $o_do_colour$trailing_pt$o_do_normal - } else { - append emit $trailing_pt + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$trailing_pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$trailing_pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$trailing_pt + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt + } } + #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { + # append emit $o_do_colour$trailing_pt$o_do_normal + #} else { + # append emit $trailing_pt + #} #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext set o_buffered "" } - + } else { #REVIEW - this holding a buffer without emitting as we go is ugly. @@ -759,11 +796,14 @@ namespace eval shellfilter::chan { #puts "-->esc but no detect" #no complete ansi codes - but at least one esc is present - if {[string last \x1b $buf] == [string length $buf]-1} { - #only esc is last char in buf + if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { + #string index in first part of && clause to avoid some unneeded scans of whole string for this test + #we can't use 'string last' - as we need to know only esc is last char in buf #puts ">>trailing-esc<<" set o_buffered \x1b - set emit [string range $buf 0 end-1] + set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal + #set emit [string range $buf 0 end-1] + set buf "" } else { set emit_anyway 0 #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer @@ -774,15 +814,18 @@ namespace eval shellfilter::chan { if {$st_partial_len < 1001} { append o_buffered $chunk set emit "" + set buf "" } else { set emit_anyway 1 - } + set o_buffered "" + } } else { set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code #most opening sequences are 1,2 or 3 chars - review? set open_sequence_detected [punk::ansi::ta::detect_open $buf] if {$possible_code_len > 10 && !$open_sequence_detected} { set emit_anyway 1 + set o_buffered "" } else { #could be composite sequence with params - allow some reasonable max sequence length #todo - configurable max sequence length @@ -790,39 +833,74 @@ namespace eval shellfilter::chan { # - allow some headroom for redundant codes when the caller didn't merge. if {$possible_code_len < 101} { append o_buffered $chunk + set buf "" set emit "" } else { #allow a little more grace if we at least have an opening ansi sequence of any type.. if {$open_sequence_detected && $possible_code_len < 151} { append o_buffered $chunk + set buf "" set emit "" } else { set emit_anyway 1 + set o_buffered "" } } } } if {$emit_anyway} { - #looked ansi-like - but we've given enough length without detecting close.. + #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. + + #looked ansi-like - but we've given enough length without detecting close.. #treat as possible plain text with some esc or unrecognised ansi sequence - if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - set emit $o_do_colour$buf$o_do_normal - } else { - set emit $buf + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # set emit $o_do_colour$buf$o_do_normal + #} else { + # set emit $buf + #} } } - } + } } else { #no esc #puts stdout [a+ yellow]...[a] #test! - if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - set emit $o_do_colour$buf$o_do_normal - } else { - set emit $buf + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } } - #set emit $buf set o_buffered "" } return [dict create emit $emit stacksize [llength $o_codestack]] @@ -849,20 +927,29 @@ namespace eval shellfilter::chan { #puts stdout "" set emit [tcl::encoding::convertto $o_enc $o_buffered] set o_buffered "" - return $emit + return $emit return } method write {transform_handle bytes} { set instring [tcl::encoding::convertfrom $o_enc $bytes] set streaminfo [my Trackcodes $instring] set emit [dict get $streaminfo emit] - if {[dict get $streaminfo stacksize] == 0} { - #no ansi on the stack - we can wrap - #review - set outstring "$o_do_colour$emit$o_do_normal" - } else { - set outstring $emit - } + + #review - wrapping already done in Trackcodes + #if {[dict get $streaminfo stacksize] == 0} { + # #no ansi on the stack - we can wrap + # #review + # set outstring "$o_do_colour$emit$o_do_normal" + #} else { + #} + #if {[llength $o_codestack]} { + # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit + #} else { + # set outstring $emit + #} + + set outstring $emit + #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" return [tcl::encoding::convertto $o_enc $outstring] @@ -2260,7 +2347,7 @@ namespace eval shellfilter { # if {!$is_script} { set experiment 0 - if $experiment { + if {$experiment} { try { set results [exec {*}$commandlist] set exitinfo [list exitcode 0] diff --git a/src/bootsupport/modules/test/tomlish-1.1.5.tm b/src/bootsupport/modules/test/tomlish-1.1.5.tm index 35de5e704f3c9f66b7648340e6298f248a15f998..3ae60d426cf6b63988005e9d06eb1aac81a2c04f 100644 GIT binary patch delta 8502 zcmZWu1ymecwxt^h?oM!T+}#PDpuq_eT!TA}BtURdc!Ik-L4vzWu;5OD2X{V?mzjC< zr+cm2d+)RFsjhpg`a3osB80xyU#054cvKpY#hdKwml4;xXFR6R#j z4Tnxzo}ini6yQdU4Flt(2P`M^0Apl~P#cGNxr966dp!6bDD-HGR*YOh0R%nvyuXLw zK1Y#6k%++RVJevFm?%|oGpkj}j6s)g3fAVm_#Fi!YXfQ2VqJG#cNSy~j*aM=g#=Wo zR38Qcr9V!hsGCg$1!>C+w7sUC)DK=e#SL#Ta-~>NU%-^+O3m>=(GnH83phv`gwn*U zW6~^)#w9{p*#uK}@RVg^qe`W33F9RVmGJWpmd-$TA%P#*)U76HP9~UDvvFS-@yS%a zq9Q_gNU-vs`1$5J=Ba-7n3OM5-0uygE6JV~#2^h?_JVHQmRXLjHN)g!(J+0;sTp=5 zzd`utZ{7w!4S8{7>y{TQ&lAUPZlR4NfhnimJB`#16Q5lch_-Otrjsu`wcq{5fD*cU z`E9OcaBfv~X~-HI<*m*635Ybmbm8tWTtiGD(X@W=#H-G(CKNAQr>4F~INeIaHKm!w zQmBw>R+!nNtDvfq%U_Sj^o;;Nu)IuhP+!MBwc9TRt~yrlG7Ao0H8@Yb@GBG_!o7pl zal3M^N$YAwvR%qrCJ^A~dVbrcNS@T3vS-tH_KL;$_%`!$v=g4fzNmVP04Ij&1JW9j zZLG$qB###55+nx;U4x1pz6Xmu5X-fqSv3y2F@J;PMP)EDd8Epdd1w1jbWgy&t3_;I z5^7KgX3gE-{h-iO5um77=LB7>MJ`TE7_jP8`!Ut6OuhuYZqhbrzDmc~HrdpKZM*w@ zJA-j3mKJ`5?{|AGUm_>y19f+Fb-h1;jy^DIGTjn*V{BTOoc-E4zUyuM=-H~o}P{k`v>Tmv)@~=W%Kh-*I9079VK@=?9DKjhMNYQbSKVDp_$^1zUu>TUh8(h0jzH(k^8Au=i{&5#ib+4}OjGZ)i88Y6g9z<> zw~Wch)>j8qJjD?Nlh!rf%G!628l(0!Fev3j6KI*@X$aY$b-An4 zVggEcx6JbkDmCX5%IBNffqO8Trtjc@Z8sM4^CO44s>7|4%&6(9lFS1}pJg$cdw#-- zK(sKaB>i~9Rf zgumzH=vx$IaN?Vi=8r3wUptKUzT@Jj}^bUif@l`g8 z?doxrZLc0~{xA};P0_hGB5(gtU@g^2j7N5SodsF()PXZ*$a5-#t42UDwz5CMPipoS z{BUx4l+Dybr2i@(qO+350RAeJZh9&KA1SfpCyNziU3y1+(sisl9KR#7O19gX9zbZT zdX9TYSQ#FmAf|PRf70zhP>~5G_PMS?oM5bnbxdT9@yI_U&)plGGvW(X=n-b{eP=M; z@i5XahK!o_GxB+Q_3K)RRKM5K8qZpudD>?yA;k8ZLyVE_K-dN^f-1tYm&qibhmr_U zU~P&7{o(`R>?*;?6Dh{m%i<_{l2WcJa#Q2I?}K0+nQFWY$ydYFJ1VT-V+V)pO z;m|)2iFNkaY*b~Tn-eH*{1D=*b$)bjtHQ$2c1RnB-m>@uK}U-MPl@Ta=O|=Q9S>`} zL)8CJf~qGo7^_8F2^RSpdW8_=HFi9h;_J?Xh8he)v0YF+P7rs&IC)>F+qj8(%xm>j0wFk+# zMQMn?Zl0erY;~Hx-6D>mf+rJeKMnV!AYGq*%k(q91t(t!1fy`52hAm&;7A}RWaBC@ zQSRn`X|Z)WRgA=Jhw#be6j^o}%}hAcq1@=keBj&lAo&Bcpo1~E1S+}Zj!7cULoeEg z8MDFG6va-YlFG(A>EUzUx0`&FmUe`$zHc)t6kCVH91^$C=T{WK!2!k)a#%C-Lk}x7 zuNRr+cg`dBXdrGgh8|HJM9YypFM3wM_Tq-{7NUW5<@GII4%0zq_I)2EC+b;8Xzoa; zl#YDok}=BI7fi$P;9g15XcjN0KqE9GV(Yt=!R8SueT@-4#KDzo z-u}SJu~m*|5Ku_wPD!|p$WZ)itBe76)fkBn0U;7IBL{lc`OufgM$LUn5RUBL{nB*5 zE0?J|4@a}{(!-XiI&1FR3Rm_7x+4XDM-RsMcQT+}2bS0{nj|IA-TEkUHbuaq!tUL= zn2@Yh-xc14g>R)WNt|D+J<`33g(V$CKHe#jAHj0S1H3e+$_j^p(%ptur%5#HjGbtY z-^g}q@hUm1cQ@g)K6GYmS-F+S;ZeYQ1`7h9m~)W0!^D}4aLl~0mr>SAw%rGIE$I$ zvwrJEOy{I5nXG(baW*0YqSR_Y5n|grMp4ddtpJHS#9CVl`yHjN^PH zxUD>qfc#<0JYyI2ttbZLP)R2%!}zAsN4~^Fhx>l6Af#Rso;rdh=(now@(&?Foug7s zfxk!BiJ+?m;S$c;AdhUl_oY7Z9g&x%gx;7TFXY;Zsq7Wf7S#L&@R-`GAqzFgYPX~3 zr|QAQh~eoOGaddc*ZV`}Y1^HM!SeWwam&^(%YWiD0crl7cWNWs}3GC7q8IR+)*5=y&YsYxH;AB?xkJ>x~=5dtem+n>PTws4?0_vNmQGsByf#` zX~9svPPts{5LB}O==8GRjL2+KtD)B0`9*us43k zRnKn{(HKsj=R6_9*&Y`go|uyn>bh5*mV|0CF3y;Ch*q_>hvUqnWcFVSa96EH2eGZ8 zWO0=G&iAASclg_-aW9-k=i`084J+hs8nvg;R;7LDK#|XmGXd3gaioV|_F8JosXk|- zqUkaDhD)(qi2b#H6z)rEm9yhnL{|*UUZPO~ zV`kxFPm^Zx6}Um_{NGEUQx%e5r|B}XS5G9FYad(DvE7Vrd zmAKhw0F^-ihRn~sJG=PbdrH6Wq)<^r^1Uz|)-X)x^1W+EPv9A`CGb9DNZPVUV4-Re zUW&W0OB8li(UzfgW>>nJB0*$bhaSO}tlH$foz)~PkzYBOY|aj{M|IN8=%u|7j$k{U zEf>l_5R}sF+pt(8Vk(p|#(8Cq|jf8+rMl8l>-9ut?fm)**6;wBlihk+qkGN^c8=t3RglN z3iw+r@2PqGDd~OFfg8q34!(=Dd&1<~m-;k5;ub6fCm~o{p%FfTyme( z2a87O-8%uX=RxOWv_0qj=LIn#1~*O?Z_^9wH>4o9oc6@=>R*+F^#{Gh$_R`z}5U}J5T)qBJRZ)IQWf1~2hw63 zl3Zc)O)Ms5BI;FQ^tubDkUra0$nz_kudr@n130orhNt`~;jUlhZTDE5-YjaoCLnO{ zn(UDhC}thW;$TK9L1R-;pM*VBX8x2)gk4o-c*Kn6qmJGe0=4oF1{+>q4R7K#BT>V^ zeIsO2ros}ZUYG6{iZH=1$MF4ef9piHl*Ol{IyPnJJWgIWo%w1ubew01rH5F0W-HA_ zrzg6?zv1VE(Hw16MY2*`Cez3F`%_e37koI-_5%q7f1}AoY@qruJ8IZlZU&XI5y-9p(?`isZF zC}8x~6dKcH-^q^p!W{~~x+k%pQ=Z8%=D;u}F)cnXO(UJ48yf{}O)%|Z5ZuvUjY(v# z4B#ukdl(`_x(@A(fA4Bg*~R;UCMZRcW>JWnC>J5ys9GgcQfXBTQ#R;It{pN}V%)!f+C!`8~)=HcNfAwcRw21s&n01m?# z$WM-khsQ%#hxjxz6a8!7Ornx>UkpF{eFqN%!^Q&xBLR#@azg)3&i0Q(?&~c(tjS>d zi7`HOB6?UB!@(P}Vra+}da1fL?i{$t<|@EtcE3T#sdoFe3-|uE)!qCKcAikk3g?sJ zehA#*(8$Qh(1oY1ly_h5Cw6CF_QlOlD6VT)`c4ni_{)?>%z5>~Ue2dIZ?|}EM%tm< zd;$B;DtSTJFR0oR^s~Oewwj@z-q3_1@X9*CM3)9PpXwXNzT$3OexOxrFl!mkL!Z<3 zT+mq9ktlwR85>e27coKEAQ^4CQlKG3lb97f|8!xWO z#a7_(0@h5ZYFYN>rnQ+-#~hXoQ$Yo^{^Lv#&MDPV22PVZr)#O}w7lS4+D5=;8nb~UkwH-MwZYa#qe%>!h z=oVm{7I_p3-hvZ^eAP4~XXIw~;YiUB;VAg#PLkVWW)+za1O(qP89IJ3W>g#V?yMir zX_jpt=^ZGQU3ocK>_TR=qnPxIvC@cWiu{Yji;(u(@uOJy7rqwEZ+-bZld+{lX_{QP zVsBqexGB~Qe<#rqr_MqXev4WMh1-%NF!{8qNjB&x!&R7ib>JjvQK8cgBNeLnJ+H&j zFAop8G}0wmVS8GP6KzVDBbb9Z^|Cculf9Cwrsh`}`=0f_Z6=FHm+-VXE zl+Q{u+$b!h({G4pr!_~@+UYD1`Kg$aiSR)N{xjRrdX9(-vER%kcaQHvRyS|@X9gXh zcLHC0u7$tcp4&NHT_g@JJMynsT~u2%bw$5Z34~-`k^X)v!0HUH#N!X2aFU$}dgS z_|E$NAhH3~j8I-mqRkP$78We`0P4$8RF4>T=qx7}y~C2Kq`f4S*0cTafc8rUu^a5| zcbZ_rC#u`vRF6$m(1kcSJQm8wIi)5R6!r^(vsP>(QCo%OZM~F12;~RM#KQ8Au4}8% zj|s8ppEkot(8qWClB+TQO!@is+{UfSvOvXIy4(8q`7Xg=&#z_H1iE6kTImxIlL(jM z;W77#Z`}c2zsEq1U0?!M^9FIM;F7N#4kzJRROIh!OiPjE7pdm4qo~xkm53}+RRNCn z9=WUWK`zh~0XoIWYUo*{O2C`Cz)+Lp$i?s2uk;KPt$x_`&ItABu{XAI|9pe0moOZ@ zne*N8YH{)*VpbRL<#Zae;m0sW!j5_b$P~Mr;|Gl*9;JEq{eUFR6$?}?PZ9#8x1W6X zTI@_C4Bu^QD#VFdpYUcKlv2hAYoNR7Su%Oa*GMspv$GSy4x~cu^lJB=8)eN>hE2wV zTF3}jQ8rT!&X`t{X~uqfcXFeB7l!}-^V!Tmt-jLXIT<@8-s=w9*Lyk3^s^?)hd6qX zE@?UNRBi9sE@dj4JXlCEWm29y2xbH)qMu!>;h^$x!RyK|Nnz)UOLIi`L8y6U0%?l7 zXJW_l5^e1C-3F$hq}$-pX?FHd)fqM*NZZ{&M!bBJQC+?aLXK>9tX-Hm=$K2lDaPs_ zOh{rP{G3B3`r@!VN_CybAc%#z#Y?G3`gWW;ZOWf)p*$98K0w9ZXv8%#8ocUEufTG} zF|Dw@y>0BaqbK5puy1ioCo2*?aWSt@aJsj*H}%dcF4h`)|9ny;l?`7a*GWELl5nP5 z-R|VgyoX*BwmC0LfA9|yb208}*+aC08Q4K1;@b8D=FuzVo-^v{RFmC!W}hPX9`tg8 zNiW@Z2#ghomWM}dHSJFDsjWuW=?T7H%Nk(zYBstD3OFpEzaMjFs_dco{ZRMHh86$N zntS4!u5?S6cS2t=ZKKk@gfGG`8fObSVCopcly=8~)Bo`AqJ{|bu_j4($!qPh>anPZ zBE!Il0hu2GK`Zf}%&=)77kwziC@$c1jckjBJmJS!GW85)2nxJew39>k8xE&F-` z7sMAQh1-BJERBa?G~XV$X+~LFZ8a?m9e@3{D)ZC$d+MAQX#`mYzfvUa79pKH8a&)5 zwa$BQp2H6C`gDLaplHpRrNb zo}Y$|D0!>ivH514fw9Uxzu0x3IN$6emCc!5;aFt?!fH-`xO(>_BrL*Q|HZh!2eiPv z{-)FGAY3+uw0b?_G8=gmk_$EIB|%>bblPO|dhc@cvhQGZH@eR+B$O}hRC(cK<$BHU z+C|9s91cOynAm6qDU^&%=%?`nc5~FfPpB z{oUi!LqN6gE82fOJOuEHqQEZ+fYmAvV7kZ^y!RKB24aiZK$1XvaX1*3>`_nzRs_(1 zyb=f~0~jxf0LxK6iR@(HSHsF4WS5)(Xjd}h+G@wiw2{@`l1vG2Oz;3)xa(fLIn4a$m_Sa%P-45ScRKTp844n0s^a2>@HUr53>^+5`wZ~B$IB*kqvKaP~f&B~~En+}R zuNep*80(V-ls!-Yw>}+E<0GpCzcG9YTYHK<%|II<17H6w*$!BMQ;eRXBi;x=i5JV0 zW77*4^*@UUG5%vf2E@HNo(xxmWZ;f}$?|_m6#vuS|0lsCvN!qbY)SsncK`oQAIRt- z0ZNC+z^5ia<)}D-Hp~W2v3!IQ0CZRw3~T!bA^^T_C;-L?1RU+~B>9Z+gD)JPV3<1w z5H^AeV2_f4Ke{|ha!)JqVH5)D0xCuWz`wnL$}t(hKOPnMFa`mq_&-u_uyg3sY=?0k z@O;=GhyWORBRwT^&BI3j=edYR{@ZfzjmiAazmosC<@o137`&Lr3xh-SfA2v4nc{y+ i&wr(GO!zAW-T$vdDvIz3fBBRj-x&}XnBb(p*#7|@cE9id delta 6274 zcmZXYbyyW$+qc<6$7TZpg2HA?vq4(vl15TMLOP{EK$Gp52%@w|m!c?L z((rO~`|v&A`_3H49M^gNu359z95er{$VT*-T=a@)^r~2Nd2)3A>V&E}$|?-#AmM9W zZcVdn4iYr9JTM(@h&pwc;jg{$*wZ3XW*;Rqaa-SHCvU*n+_0-^>e=88;0>6PHle8Q zp0uVPVO4n99DI4`1%EfcLuWTlIa~kSMt%97$I*@u?1^Bq{FbtEyxe%(dxRS8L8nH_ z{vskVmfKMi_d!w?zetY>yEZk>5h)+Wh$0iqd}o4+3My0R2Z|f_J3j{QA#FJ5KC7@hzN1OSbOy0)Z z*cc*OT>GjEc;>aDLUIXV%VxCGW*K^!j$Dvz}CvSMhH@O)CFkjh_|8Mh2>pCo-M_7e%#g24^z*R5ot*rR_6Py9GCN4hrsx!tmKImSEqMhsyP+GW3B07#`>Tq+W6uzx4Ip}bX?K6PU0Qwl3Y?u z&G3L{m7QM3v`4=ic|Rxon$TI#m*>3O5XPZkL}LD2Fu@aLll3SEe(w{^-a+$8QmvYU ztCJGuiRQ+!Uy^8MOX|8!sBr!Faz1QJ>|DR3Z2oL0#JTcC6=d+!|6h3;m%*S<_g7vPneSZ?9ukBvbomINzFStIIJfD?3&v2ooQ=d{M<>{^eP~CL zy^k2el-uzNv;%cd#4jWW)(S>x_jaBxJJ6l`Z{MH#DJ{M?M0%N)d(=x&4$+>ko=89M zLq!>#_A3V4A&XppozaNBZ41(z6=`d3uAhDB7NWXtWf+z-rhc+R?z>(v+*t99GH?~c zs!5>)Ww<(1GfH+VJ^b4X$qx-)OwrUrohKJ78(%n*e)<=z?VimY8~QoSQ@ho=zS2ny z#NH_#4B3bKj`Mm}#GZUrsx=hr+d6eRz3?{pxqZ$sq0{tf99HE*CNJ%Q%QKT#Qbogx zt}$*$lv6$=ypHZE{Du+<>yyBCdt<%cS9&B6iRuuz9Tc&@vmD;+Z*6&B!LZ$slH>U6 zW4+F>RF)L4LzzB|ET{%#2~w}4#|BEVE7jtpXqb9&TKCDv7WVmwz(EtC?(2=$#9 zMoG|~rMVv|o(#RaY+^ijkV}K@VcwpsK@j(xvLGL)0H%?Mra*1ElcxV`=qvPaOlLo_)^N`CRH^Sh z*|tPrJ&P1s5t5-Y$s8Giw)S}M%rMv%U~RRs`McmPiO=TZ)6Y+x%2J-be=rHnj^l#K z&^$`2*+zZ)PJ@Z%wl5PsG*vupgi>xp(iWjF1PIruF$VOR@g#5t)uM%!WlL)Jj2wm# zF)jBJ%1L<)8J(~jnWW(&SWFA!4xgK_l+)3Bhgq2U4>!EGA~p6imyAP@t21;EY(%{0 zz?kxJ2y<*SO`ZeQHs%gAejE4mOt;cbTRUwz3eDoER#|z3)2h2ay`DH9w{NqFBRJr@Q?8Mx6mR?%%c{mk>0wQ8N?ReJAa#?1&Rwt zk0RP-J#Fl55xH*uan8=$5mw^zVhcu3V7k6Kds}6BejU647vA!x)Nq=} za4kbV>v!1e)*-8yM>LFgdA`0PWpO;k9q0Jr=MrgJSDN|uMET7o1{(80TEP-j)E&6p_6$)mv8EyTlD z)}luUN%6S0b-_+Eao5&KwQoC9_scCiy*xXG6l=9TFMgs4;qNwukP~4*1uGnKV z_;H%)K2DH?Eo3>U8NjTC&QD;_eL!p#AbEgxkZVg5U>JnV){aRc!Cmgbi69b?3eGa1 zs2rzsV!msoEwm0vy|s*D)!o+aJFS#fQ6?&Z6l6`nT4&dUyAQ;D`9p$!PPu)Dua)<0 z#cUIlIe=_(P&>GDHi;ue(O_f!L|4^&Bvj*=U4grRbDQ(m^pubMMztKgSU8M zN*eXNJR2I+xr681bFO2^HiVVCQ2s1VY@BjbYDG17mLUd0&XXZt{W2cEZ=`Vf-|=Gf+0UHnMMs;D zUVxk}bq}sVok)XG5(6)ui-Ho|%jGNddD1QiMg)>go<;n8*ys}P=i+3B6j>HIc-+r$tJc)|wdLK4dfg7Ri8Y_m0N8{NuSE&s zu&pa<4;G2%&}20Cg&x;v9RrsRK}zC6n3;#4PiQlWx`4%^Y+6<8wSBOn0tVdvoCH#f z*}6qFxV^;iZD~F_;>-6dbB^>7d*@h1*kmM?#KSPJXV7}gWP=5xiuf{V;C{LDk-Uu@ zPDm&QE5+*-i?IyMVaNJxg}E4IA6vVtiO08GXR+>nnZNXFWsOQu}v zPjFc!b{_u=h3s5rTCL$+jPMnzOF8hS=-}+93)+1aHP3Sa%md%CSJ6{-UKjcIq>u5Z zv3CT-X6d^GLgr-D+2lQNMZ9Q=fsB1Rf`U=i&ToL6)s&OPYC z9m(czK6-iAue4!{5nha+@5FGFz7noixxkyns}vZhYedJFv#<(ia;y}>v2xjtMf z+)XZja+wWRTplP6e{;uRGjaaM_I#wtbF;kZ<&YwV8YeLeeKUm*N(^#AN0ur1M&We% z3y2Z@Xx>>W8Ds*#88iM_)y1Et&5jRe=fQVoHecTA>tL3BOGKLYTXe&>j@jHfKls!y z>4j0lH&oKrl!=wW*oL_S)?NCX4fv=i2r!MHh6QcKT>><=w;#HHbVjUCJ~&+%jhMCT87C9VUt`>tPCW~J|2aZXCf*U2N}Y@pmklo?PWJS$4Q#}& z>Egr@)Uf$%A=%IH*2C}Nc!B_pnEZ^pMSGKS30$a@b&a? zCp(9g*_|kQB!vXvg>S3FAofO`gzUPBA4!zxqj1Z*?KNq&)p+6NYcw+t5Fmc~3Pot_}5h#!(LYI@B|SWXkH1apF|lK3X`}+H z$6LMz*b}@!X34T0&bD(5wi>#%ySN0SY`a+=_W0;<=Xb)DJE#}6=?az56Z*Q-CP>1L zY>kzCdD3g&-!Bb`N`GN%go#C}$EU*N9_mnBZQ~}DK0u|&R~`P=Vjw=~S$UQ@r$Oz; z^e+s2N?1$2iyvXUkWq}9_Xf*j)^CA7!r##0?lFzvq}K{3;_DYPJdN-T?ajXjLH+(p zHPc1jQli~+(>=gnW?Jv}{7|-rY{t?#h~BT7pf|Ni|{WXkrTUXvB}A zw_=k_7S^H(s!hdDoq4PhMmTLxUTJ`5R9)r2GMno56hw;VW20474ATO4wNE$~=$P97 z(4zLjoILP_d0q^4#=}={74OChmNA(crs_z#)= zWbY273wv&k*Mci~s4F0LU1eH5AyowySGP~cmL@pIp8E-`hr{_$kmP<`^~@v%Jn zm%TbLXI)PF`ma*D`C~l8fzv|9baKgyfiA6CSQ{b=ksIKK+C5m)pOtq3ANWzKaXE1B zaOL~kpPmuxN$@7Wunmpu!2Zg~7`Qu`6gDvIx@N-g%7+z!wpWdPFotPqaaa&Qp`d)34Z&ivc3)ojA-+kzygbADdrXm?!r>nJ`@X zO)5H)3MbKGQkLl}+wI6IYHgH)_SQ#_yEL{TgiC+4^7kZiKggJI#@0bfDAw?IBXH?b zW>XCEoyQ6tijPW^)-UnKodO{v4ka9?3QlKb_wHt+y#?zN^OKY$yx;@anLJUv@EdBe&N{0G(e z2CLnC2(CDu(8_MLhOC6U?0T!^Gi#E8BeND5uXpQ4#X_gEiwPxACNWaXouq%f}Y?Zx;w}+!G^W{pc>|_>&AC`Wk=F%j@Pu#8bTiwQE9*n~B zso`9oE}?9>{GC_zYp9V0)-S?jmh>tI)^Ahw%I?XmSM%zUQAfaQ)Nv)-ENhPG1N7LQ z&4X5D?D*Bk``JDTzxee8&2_%h(rWSX8GV~rE+`sany|xW>Q0Zl{~bn?%>h8Sa4h5p z4aIL2a0ODi#u=0KpF#sZEl+U8C28KBQ<6Q)5fBcKvA9=8WK$Jiz}I8YlvhWKo@ibK z{zygKGI`bvB@sqVD&6xjF$`W_S9CeGt2Onqex9@RoJXu2*MAk-NIaW;{@DqFFBv8vw`M~h<>B^MVrvGI!pU9)2$ z(h)Q?GRBBJMvvEs%nJY;yQuh(Ph~OLix7-1p zth(h{Bu{OIe#SMN5L0_fjs>ssw?8d#Hc)8V?anT4e#+u94qdqOW8rMzsryjR7A2-5 zLGi0ki4w)FGacrPjD2gz2uE2HWp)>5VUyKLNnM+Qd(v73qT zIray>@k(bJAp{yH3&8!0bR!bQmTLe(=`qYV1tW~U|?M%5~yMRFGX=ZH7qF-=+&}s4t~(7 z$sed;y=fG0<^!yFZ!lQ}3VO5=flJMI0J{e_TCPPL@PBxNrK-5#doU_62I}{40GT_u9xsm*OrVE_s2Jq0Dk_`uQuDWhZ3kYfdEipmV z3p{Y(6B5|{SFwNA2RwDI(*|csaPBh_z<73rqM(8+BWO2>1cLuTG4Qji#1#^N3`1}L zsdudkhls%wcT(_T5DP3H5(Rqy)$GHjfQkOU9d1G(bOZ^U{EO}*Hb92Kb+Y0vdp(@n zC>-(#6d#iYqdf$#&A0~%SX@N_nZL66fUnVYJM*|cKxlkjZg}B=!{g6@y#Jv5^=--% zaNvo_RR=eiIUxd^SYDT}zmkFTSF`5+iUdq;{wf7v%l>Z(1F0wZ0WGH+EOdi`tdj&_ z)g&DF<$R;vM@YbesjG3O;1GIHZORW&^STM)iNqk|^wla+H%i`<2+X-sV<9(+XyySR v6n=x5*;wG#IPUesa%SK_M&$n&QF{}St3JlW`sV{vygK<<(9m3C{-OT?q*SmI diff --git a/src/bootsupport/modules/textblock-0.1.3.tm b/src/bootsupport/modules/textblock-0.1.3.tm index 8c778061..9f4e75ee 100644 --- a/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/bootsupport/modules/textblock-0.1.3.tm @@ -4301,7 +4301,7 @@ tcl::namespace::eval textblock { if {[dict get $opts -frame]} { #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table [a]" [$t print]] } else { set output [$t print] } diff --git a/src/bootsupport/modules/tomlish-1.1.6.tm b/src/bootsupport/modules/tomlish-1.1.6.tm index a562545a..7abbaeae 100644 --- a/src/bootsupport/modules/tomlish-1.1.6.tm +++ b/src/bootsupport/modules/tomlish-1.1.6.tm @@ -265,7 +265,7 @@ namespace eval tomlish { #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey #DDDD switch -exact -- [lindex $sub 0] { - STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - TABLE - ARRAY - ITABLE { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - TIME-TZ - TABLE - ARRAY - ITABLE { lappend values $sub lappend value_posns $posn } @@ -311,18 +311,16 @@ namespace eval tomlish { lassign [lindex $values 0] type_d1 value_d1 lassign [lindex $values 1] type_d2 value_d2 #DDDD - if {$type_d1 ne "DATE-LOCAL" || $type_d2 ni {DATETIME TIME-LOCAL}} { + if {$type_d1 ne "DATE-LOCAL" || $type_d2 ni {TIME-TZ TIME-LOCAL}} { #we reuse DATETIME tag for standalone time with tz offset (or zZ) error "tomlish KEY in 2 parts does not appear to be datetime '$keyval_element'" } if {$type_d2 eq "TIME-LOCAL"} { set type DATETIME-LOCAL - } else { - #extra check that 2nd part is actually a time - if {![tomlish::utils::is_timepart $value_d2]} { - error "tomlish KEY in 2 parts does not appear to be datetime. (part 2 not a time value) '$keyval_element'" - } + } elseif {$type_d2 eq "TIME-TZ"} { set type DATETIME + } else { + error "tomlish KEY in 2 parts does not appear to be datetime. (part 2 not a time value) '$keyval_element'" } set value "${value_d1}T${value_d2}" } @@ -332,6 +330,10 @@ namespace eval tomlish { } set sub_tablenames_info [dict create] switch -exact -- $type { + TIME-TZ { + #This is only valid in tomlish following a DATE-LOCAL + error "tomlish type TIME-TZ was not preceeded by DATE-LOCAL in keyval '$keyval_element'" + } INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL { #DDDD #simple (non-container, no-substitution) datatype @@ -383,8 +385,8 @@ namespace eval tomlish { } - proc to_dict {tomlish} { - tomlish::dict::from_tomlish $tomlish + proc to_dict {tomlish {returnextra 0}} { + tomlish::dict::from_tomlish $tomlish $returnextra } @@ -437,7 +439,8 @@ namespace eval tomlish { #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW # #TODO - set tomlpart "x=\"\"\"\\\n" + #set tomlpart "x=\"\"\"\\\n" ;#no need for continuation + set tomlpart "x=\"\"\"\n" append tomlpart [tomlish::utils::rawstring_to_MultiBstring_with_escaped_controls $val] append tomlpart "\"\"\"" set tomlish [tomlish::from_toml $tomlpart] @@ -519,6 +522,10 @@ namespace eval tomlish { lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} } else { if {$vinfo ne ""} { + if {![tomlish::utils::string_is_dict $vinfo]} { + #e.g tomlish::dict::from_tomlish was called with return_extra 1 + return -code error -errorcode {TOMLISH SYNTAX INVALIDDICT} "tomlish::_from_dictval Supplied dict is not a valid format for converting to tomlish" ;#review + } #set result [list DOTTEDKEY [list [list KEY $k]] = ] #set records [list ITABLE] @@ -645,6 +652,10 @@ namespace eval tomlish { } } else { if {$vinfo ne ""} { + if {![tomlish::utils::string_is_dict $vinfo]} { + #e.g tomlish::dict::from_tomlish was called with return_extra 1 + return -code error -errorcode {TOMLISH SYNTAX INVALIDDICT} "tomlish::_from_dictval Supplied dict is not a valid format for converting to tomlish" ;#review + } set lastidx [expr {[dict size $vinfo] -1}] set dictidx 0 set sub [list] @@ -1522,30 +1533,28 @@ namespace eval tomlish { #DDDD if {[::tomlish::utils::is_float $tok]} { set tag FLOAT - } elseif {[::tomlish::utils::is_localtime $tok]} { + } elseif {[::tomlish::utils::is_time-local $tok]} { set tag TIME-LOCAL } elseif {[::tomlish::utils::is_timepart $tok]} { - #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a previous localdate - set tag DATETIME ;#?? review standalone time with tz - no specific tag - only allowed as followup value from DATETIME-LOCAL - } elseif {[::tomlish::utils::is_datepart $tok]} { + ###################################### + #Note we must allow lone timepart here (not just is_time-local which doesn't allow tz offsets) in case it followed a previous localdate + #set tag DATETIME ;#PLACEHOLDER tag - review standalone time with tz - no specific tag - only allowed as followup value from DATE-LOCAL + set tag TIME-TZ + #This will become a DATETIME or a DATETIME-LOCAL (or will error) + ###################################### + } elseif {[::tomlish::utils::is_date-local $tok]} { set tag DATE-LOCAL - } elseif {[::tomlish::utils::is_datetime $tok]} { + } elseif {[::tomlish::utils::is_date_or_time_or_datetime $tok]} { #not just a date or just a time #could be either local or have tz offset #DDDD JJJ set norm [string map {" " T} $tok];#prob unneeded - we won't get here if there was a space - would arrive as 2 separate tokens review. lassign [split $norm T] dp tp - if {[::tomlish::utils::is_localtime $tp]} { + if {[::tomlish::utils::is_time-local $tp]} { set tag DATETIME-LOCAL } else { set tag DATETIME } - } elseif {[::tomlish::utils::is_datetime X$tok] || [::tomlish::utils::is_timepart X$tok]} { - # obsolete - #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a previous localdate - #e.g x= 2025-01-01 02:34Z - #The dict::from_tomlish validation will catch an invalid standaline timepart, or combine with leading date if applicable. - set tag DATETIME } else { error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" } @@ -1662,6 +1671,433 @@ namespace eval tomlish { } + #return TOMLISH { value} from new and existing typeval dicts of form {type value value} but + # some such as MULTISTRING can be of form { ...} + # + #Don't validate here - validate in tomlish::dict::path::setleaf + proc _update_tomlish_typeval_convert_to_new_from_existing {new existing} { + #we deliberately don't support container types that can contain comments e.g ARRAY, ITABLE, DOTTEDKEY + #This is also not for higher level constructs such as TABLE, TABLEARRAY + if {!([tomlish::dict::is_typeval $target] && [tomlish::dict_is_typveval $source])} { + error "_update_tomlish_typeval_convert_to: target and source must be of form {type value are contained in the table + foreach tr $tablechildren { + set tr_type [lindex $tr 0] + switch -- $tr_type { + NEWLINE - WS - COMMENT { + lappend updated_tablechildren $tr + } + DOTTEDKEY { + #review + #UUU + set dktomlish [list TOMLISH $tr] + set dkdict [::tomlish::to_dict $dktomlish] + set newdktomlish [update_tomlish_from_dict $dktomlish $subd] + set newrecords [lrange $newdktomlish 1 end];#strip TOMLISH + lappend updated_tablechildren {*}$newrecords + } + default { + error "update_tomlish_from_dict: unexpected table record type $tr_type" + } + } + } + + #todo - add leaves from subd that weren't in the tablechildren list + #ordering? + + lappend output_tomlish [list {*}[lrange $tomlish_record 0 1] {*}$updated_tablechildren] + } + DOTTEDKEY { + #We don't have to check toml table rules regarding created/defined here as dict::from_tomlish has already ensured correctness + #UUU + set dkinfo [tomlish::get_dottedkey_info $tomlish_record] ;#e.g keys {j { k} l} keys_raw {j {' k'} l} + set keys [dict get $dkinfo keys] + set dk_refpath [lmap k $keys {string cat @@ $k}] + + set kvinfo [tomlish::_get_keyval_value $tomlish_record] + set existing_typeval [dict get $kvinfo result] + if {[tomlish::dict::is_typeval $existing_typeval] && [dict get $existing_typeval type] ne "ARRAY"} { + #leaf in supplied tomlish - source dict must also be leaf (invalid to rewrite a branch) + #e.g + #DOTTEDKEY {{KEY j} DOTSEP {SQKEY { k}} DOTSEP {KEY l}} = {INT 0} {WS { }} {COMMENT comment} {NEWLINE lf} + #existing_typeval: {type INT value 0} + #e.g + #DOTTEDKEY {{KEY j} DOTSEP {SQKEY { k}} DOTSEP {KEY l}} = {MULTISTRING {WS { }} {STRINGPART x} {WS { }}} {WS { }} {COMMENT comment} {NEWLINE lf} + #existing_typeval: {type MULTISTRING value { x }} + + #see if source dict has a simple typeval to set + set new_typeval [tomlish::dict::path::get $d $dk_refpath] + if {![tomlish::dict::is_typeval $new_typeval]} { + error "update_tomlish_from_dict - update dictionary has non-leaf data at path $dk_refpath - cannot set" + } + #update if type matches. Todo - flag -allowtypechange ? + set e_type [dict get $existing_typeval type] + set n_type [dict get $new_typeval type] + if {$e_type ne $n_type} { + error "update_tomlish_from_dict - cannot change type $e_type to $n_type at path $dk_refpath" + } + #-start 3 to begin search after = + set valindex [lsearch -start 3 -index 0 $tomlish_record $e_type] + if {$valindex == -1} { + error "update_tomlish_from_dict - unexpected error - failed to find $e_type in record $tomlish_record" + } + set rawval [dict get $new_typeval value] + switch -- $e_type { + MULTISTRING { + #UUU + set newval [tomlish::utils::rawstring_to_MultiBstring_with_escaped_controls $rawval] + set toml "" + append toml "x=\"\"\"" \n + append toml "$newval\"\"\"" \n + set tomlish [lrange [tomlish::from_toml $toml] 1 end] ;#remove TOMLISH keyword + #assert tomlish is a list with a single element + #e.g {DOTTEDKEY {{KEY x}} = {MULTISTRING {NEWLINE lf} {STRINGPART aaa}} {NEWLINE lf}} + set dklist [lindex $tomlish 0] + set msrecord [lindex $dklist 3] + #e.g + #MULTISTRING {NEWLINE lf} {STRINGPART aaa} + + #error "update_tomlish_from_dict MULTISTRING update unimplemented. Todo" + lset tomlish_record $valindex $msrecord + } + MULTILITERAL { + set toml "" + append toml "x='''" \n + append toml "$rawval'''" \n + set tomlish [lrange [tomlish::from_toml $toml] 1 end] ;#remove TOMLISH keyword + set dklist [lindex $tomlish 0] + set msrecord [lindex $dklist 3] + lset tomlish_record $valindex $msrecord + } + default { + switch -- $e_type { + STRING { + #review + set newval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $rawval] + } + default { + set newval $rawval + } + } + lset tomlish_record $valindex [list $e_type $newval] + } + } + + } elseif {[tomlish::dict::is_typeval $existing_typeval] && [dict get $existing_typeval type] eq "ARRAY"} { + #e.g + #DOTTEDKEY {{KEY a}} = {ARRAY {INT 1} SEP {INT 2} SEP {INT 3}} + #DOTTEDKEY {{KEY a} {WS { }}} = {WS { }} {ARRAY {INT 1} {WS { }} SEP {INT 2} {WS { }} SEP {INT 3}} {WS { }} + #existing_typeval: {type ARRAY value {{type INT value 1} {type INT value 2} {type INT value 3}}} + + #= is always at index 2 (any preceding whitespace is attached to keylist) + set valindex [lsearch -start 3 -index 0 $tomlish_record ARRAY] + if {$valindex == -1} { + error "update_tomlish_from_dict - unexpected error - failed to find ARRAY in record $tomlish_record" + } + + set existing_arraytomlish [lindex $tomlish_record $valindex] + puts "update_tomlish_from_dict: existing_arraytomlish: $existing_arraytomlish" + set subd [tomlish::dict::path::get $d $dk_refpath] + #set existing_items [tomlish::dict::from_tomlish $tomlish_record] ;#utilise fragment processing of dict::from_tomlish - to produce a LIST + #we expect the subdict structure to be something like: + # {type ARRAY value {{type INT value 1} {type INT value 2}}} + # or with untagged subdicts (ITABLE in tomlish) + # {type ARRAY value {{x {type INT value 1}} {type INT value 2}}} + + + #we can only have one ARRAY record - so we can use lset + set newsubrecord_itable [update_tomlish_from_dict [list $existing_arraytomlish] $subd] + lset tomlish_record $valindex [lindex $newsubrecord_itable 0] ;#passed in a single element tomlish list - expect only one back + + } elseif {[tomlish::dict::is_typeval_dict $existing_typeval]} { + #Not actually a {type value } structure. + #sub dict (ITABLE) + #e.g + #DOTTEDKEY {{KEY j} DOTSEP {SQKEY { k}} DOTSEP {KEY l}} = {ITABLE {DOTTEDKEY {{KEY q}} = {INT 1}}} {WS { }} {COMMENT comment} {NEWLINE lf} + #DOTTEDKEY {{KEY x} {WS { }}} = {WS { }} {ITABLE {WS { }} {DOTTEDKEY {{KEY j}} = {INT 1} {WS { }} SEP} {WS { }} {DOTTEDKEY {{KEY k} {WS { }}} = {WS { }} {INT 333}}} {WS { }} {COMMENT {test }} + #existingvaldata: {q {type INT value 1}} + set subd [tomlish::dict::path::get $d $dk_refpath] + #= is always at index 2 (any preceding whitespace is attached to keylist) + set valindex [lsearch -start 3 -index 0 $tomlish_record ITABLE] + if {$valindex == -1} { + error "update_tomlish_from_dict - unexpected error - failed to find ITABLE in record $tomlish_record" + } + #we can only have one ITABLE record - so we can use lset + + set itablerecord [lindex $tomlish_record $valindex] + puts "update_tomlish_from_dict: existing_itabletomlish: $itablerecord" + set newsubrecord_itable [update_tomlish_from_dict [list $itablerecord] $subd] + lset tomlish_record $valindex [lindex $newsubrecord_itable 0] + } else { + #unreachable? - dict::from_tomlish didn't object. + error "update_tomlish_from_dict: Unexpected data in DOTTEDKEY record: $existing_typeval" + } + lappend output_tomlish $tomlish_record + } + ARRAY { + #UUU + #fragment recursion + puts "update_tomlish_from_dict: process ARRAY fragment" + puts "tomlish:\n$tomlish" + puts "updatedict:\n$d" + set source_d_elements [tomlish::dict::path::get $d {[]}] + + set updated_arraychildren [list] + set arrayrecord $tomlish_record + set arraychildren [lrange $arrayrecord 1 end] ;#includes WS, SEP, NEWLINE, COMMENT + set arridx 0 + set childidx 0 + foreach arrchild $arraychildren { + set arrchild_type [lindex $arrchild 0] + switch -- $arrchild_type { + SEP { + #we don't check for proper SEP interspersal here, presuming well-formed tomlish - review + lappend updated_arraychildren $arrchild + } + NEWLINE - WS - COMMENT { + lappend updated_arraychildren $arrchild + } + default { + #updatables + #review - type changes from existing value?? + set sourcedata [lindex $source_d_elements $arridx] + switch -- $arrchild_type { + STRING - LITERAL - FLOAT - INT - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL { + #basic types - no recursion needed + #REVIEW - change of type? flag to allow/disallow? + if {![tomlish::dict::is_typeval $sourcedata]} { + error "update_tomlish_from_dict - update dictionary has non-leaf data at path \[$arridx\] - cannot set" + } + set newval [dict get $sourcedata value] + set newtype [dict get $sourcedata type] + if {$newtype eq "STRING"} { + set newval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $newval] + } + lappend updated_arraychildren [list $newtype $newval] + } + MULTISTRING { + #no need to recurse + puts stderr "multistring within array update - unimplemented" + } + MULTILITERAL { + #no need to recurse + puts stderr "multiliteral within array update - unimplemented" + } + ITABLE - ARRAY { + #recurse + puts stderr "update $tomlish_type within array" + set nextd [tomlish::dict::path::get $d $arridx] + set subrecord_tomlish [list $arrchild] + set newsubrecord_tomlish [update_tomlish_from_dict $subrecord_tomlish $nextd] + lappend updated_arraychildren {*}$newsubrecord_tomlish + } + default { + error "update_tomlish_from_dict: unexpected array child record type $arrchild_type" + } + } + incr arridx ;#only increment array index for updatables + } + } + } + + lappend output_tomlish [list ARRAY {*}$updated_arraychildren] + } + ITABLE { + #fragment recursion target + #ITABLE {DOTTEDKEY {{KEY j}} = {INT 1}} + #ITABLE {WS { }} {DOTTEDKEY {{KEY j}} = {INT 1} {WS { }} SEP} {WS { }} {DOTTEDKEY {{KEY k} {WS { }}} = {WS { }} {INT 333}} + #ITABLE {NEWLINE lf} {DOTTEDKEY {{KEY j} {WS { }}} = {WS { }} {INT 1} SEP} {WS { }} {COMMENT test} {NEWLINE lf} {WS { }} {DOTTEDKEY {{KEY k}} = {WS { }} {INT 2} {NEWLINE lf}} + puts "update_tomlish_from_dict: process ITABLE fragment" + puts "tomlish:\n$tomlish" + puts "updatedict:\n$d" + set updated_itablechildren [list] + set itablechildren [lrange $tomlish_record 1 end] ;#includes WS, NEWLINE, COMMENT (possibly SEP - though it may be attached to DOTTEDKEY record REVIEW) + #we only expect DOTTEDKEY records for data items within ITABLE + foreach itablechild $tomlish_record { + set itablechild_type [lindex $itablechild 0] + switch -- $itablechild_type { + SEP { + #REVIEW + #we don't necessarily expect a SEP *directly* within ITABLE records as currently when they're created by tomlish::from_toml + #it attaches them (along with intervening WS, COMMENTs) to each DOTTEDKEY record + #This feels somewhat misaligned with ARRAY - where we have no choice but to have SEP, and COMMENTs independent of the array elements. + #Attaching COMMENTs, SEP to the previous DOTTEDKEY has some merit - but perhaps consistency with ARRAY would be preferable. + #This may change - but in any case it should probably be valid/handled gracefully either way. + lappend updated_itablechildren $itablechild + } + COMMENT - WS - NEWLINE { + lappend updated_itablechildren $itablechild + } + DOTTEDKEY { + puts stderr "update dottedkey in itable: tomlish:[list $itablechild] d:$d" + set updatedtomlish [update_tomlish_from_dict [list $itablechild] $d] + set newrecord [lindex $updatedtomlish 0] + lappend updated_itablechildren $newrecord + } + } + } + + lappend output_tomlish [list ITABLE {*}$updated_itablechildren] + } + default { + error "update_tomlish_from_dict: Unexpected toplevel type $tomlish_type record: $tomlish_record" + } + } + } + return $output_tomlish + } + #*** !doctools #[list_end] [comment {--- end definitions namespace tomlish ---}] @@ -1713,7 +2149,7 @@ namespace eval tomlish::build { } proc DATETIME {str} { - if {[::tomlish::utils::is_datetime $str]} { + if {[::tomlish::utils::is_date_or_time_or_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]" @@ -2052,6 +2488,103 @@ namespace eval tomlish::utils { } #------------------------------------------------------------------------------ + #subset of jq syntax for get/set operations on dicts + # no filters or multiple targets + # meant for 'leaf' queries + proc jq_to_path {jq} { + set jq [string trim $jq] ;#don't tokenize any leading/trailing whitespace + set path [list] + set in_arr 0 + set in_dq 0 + set tok "" + set bsl 0 + foreach c [split $jq ""] { + if {$c eq "\\"} { + if {$bsl} { + set bsl 0 + set c "\\" + } else { + set bsl 1 + continue + } + } else { + if {$bsl} { + set c "\\$c" + set bsl 0 + } + } + if {$in_arr} { + switch -- $c { + {]} { + set in_arr 0 + lappend path $tok + set tok "" + } + default { + append tok $c + } + } + } elseif {$in_dq} { + if {$c eq "\""} { + set in_dq 0 + #append tok "\"" + lappend path $tok + set tok "" + } else { + append tok $c + } + } else { + switch -- $c { + . { + if {$tok ne ""} { + lappend path $tok + } + set tok "@@" + } + {[} { + if {$tok ne ""} { + lappend path $tok + } + set in_arr 1 + set tok "" + } + {"} { + if {$tok eq "@@"} { + #set tok "@@\"" + set in_dq 1 + } else { + append tok "\"" + } + } + default { + append tok $c + } + } + } + } + if {$tok ne ""} { + lappend path $tok + } + return $path + } + proc path_to_jq {path} { + set jq "" + foreach p $path { + if {[string match @@* $p]} { + set key [string range $p 2 end] + if {![tomlish::utils::is_barekey $key]} { + set key [subst -nocommands -novariables $key] + set key "\"[tomlish::utils::rawstring_to_Bstring_with_escaped_controls $key]\"" + } + append jq ".$key" + } else { + append jq {[} $p {]} + } + } + return $jq + } + + #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 @@ -2249,16 +2782,78 @@ namespace eval tomlish::utils { return [string map $map $str] } - proc rawstring_is_valid_tomlstring {str} { - #controls are allowed in this direction dict -> toml (they get quoted) + #anything is valid in this direction ?? review + #proc rawstring_is_valid_tomlstring {str} { + # #controls are allowed in this direction dict -> toml (they get quoted) + + # #check any existing escapes are valid + # if {[catch { + # unescape_string $str + # } errM]} { + # return 0 + # } + # return 1 + #} + - #check any existing escapes are valid + #REVIEW - easier way to validate? regex? + #This is not used for the parsing of toml to tomlish, + # but can be used to validate for updating via dict e.g when setting with tomlish::dict::path::setleaf + proc inner_MultiBstring_is_valid_toml {str} { + set without_literal_backslashes [string map [list "\\\\" ""] $str] + #replace only escaped dquotes - use a placeholder - we don't want unescaped runs of dquotes merging. + set without_escaped_dquotes [string map [list "\\\"" ""] $without_literal_backslashes] + + if {[string first "\"\"\"" $without_escaped_dquotes] != -1} { + return 0 + } + #assert - all remaining backslashes are escapes + + #strip remaining dquotes + set dquoteless [string map [list "\"" ""] $without_escaped_dquotes] + #puts stderr "dquoteless: $dquoteless" + + #check any remaining escapes are valid if {[catch { - unescape_string $str + #don't use the returned value - just check it + unescape_string $without_literal_backslashes } errM]} { return 0 } - return 1 + + + variable Bstring_control_map + #remove backslash from control map - we are happy with the remaining escapes (varying length) + set testmap [dict remove $Bstring_control_map "\\" \r \n] + set testval [string map $testmap $dquoteless] + #if they differ - there were raw controls + return [expr {$testval eq $dquoteless}] + } + proc inner_Bstring_is_valid_toml {str} { + set without_literal_backslashes [string map [list "\\\\" ""] $str] + #replace only escaped dquotes - use a placeholder - we don't want unescaped runs of dquotes merging. + set without_escaped_dquotes [string map [list "\\\"" ""] $without_literal_backslashes] + + #plain Bstring can't have unescaped dquotes at tall + if {[string first "\"" $without_escaped_dquotes] != -1} { + return 0 + } + #assert - all remaining backslashes are escapes + + #check any remaining escapes are valid + if {[catch { + #don't use the returned value - just check it + unescape_string $without_literal_backslashes + } errM]} { + return 0 + } + + variable Bstring_control_map + #remove backslash from control map - we are happy with the remaining escapes (varying length) + set testmap [dict remove $Bstring_control_map "\\"] + set testval [string map $testmap $without_escaped_dquotes] + #if they differ - there were raw controls + return [expr {$testval eq $without_escaped_dquotes}] } proc rawstring_is_valid_literal {str} { @@ -2850,48 +3445,9 @@ namespace eval tomlish::utils { } } - proc is_datepart {str} { - set matches [regexp -all {[0-9\-]} $str] - if {[tcl::string::length $str] != $matches} { - return 0 - } - #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) - if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { - return 0 - } - if {$m > 12 || $m == 0} { - return 0 - } - switch -- [expr {$m}] { - 1 - 3 - 5 - 7 - 8 - 10 - 12 { - if {$d > 31 || $d == 0} { - return 0 - } - } - 2 { - if {$d > 29 || $d == 0} { - return 0 - } - if {$d == 29} { - #leapyear check - if {[catch {clock scan $str -format %Y-%m-%d} errM]} { - return 0 - } - } - } - 4 - 6 - 9 - 11 { - if {$d > 30 || $d == 0} { - return 0 - } - } - } - return 1 - } - proc is_localdate {str} { - is_datepart $str - } #allow only hh:mm:ss or hh:mm (no subseconds) + #return 2 when missing seconds proc _is_hms_or_hm_time {val} { set numchars [tcl::string::length $val] if {[regexp -all {[0-9:]} $val] != $numchars} { @@ -2908,6 +3464,7 @@ namespace eval tomlish::utils { if {$hr > 23 || $min > 59} { return 0 } + return 2 ;#missing seconds indicator (can still be used as boolean for true in tcl if we don't care whether hh::mm::ss or hh:mm } elseif {[llength $hms_cparts] == 3} { lassign $hms_cparts hr min sec if {[string length $hr] != 2 || [string length $min] != 2 || [string length $sec] !=2} { @@ -2917,10 +3474,10 @@ namespace eval tomlish::utils { if {$hr > 23 || $min > 59 || $sec > 60} { return 0 } + return 1 } else { return 0 } - return 1 } proc is_timepart {str} { #validate the part after the T (or space) @@ -2946,6 +3503,11 @@ namespace eval tomlish::utils { } if {[llength $dotparts] == 2} { lassign $dotparts hms tail + if {[_is_hms_or_hm_time $hms] == 2} { + #If we have a dot - assume hh::mm::ss required + #toml spec is unclear on this but hh:mm. doesn't seem sensible - REVIEW + return 0 + } #validate tail - which might have +- offset if {[string index $tail end] ni {z Z}} { #from hh:mm:??. @@ -2954,14 +3516,21 @@ namespace eval tomlish::utils { if {![string is digit -strict $fraction]} { return 0 } - if {![_is_hms_or_hm_time $offset]} { + if {[_is_hms_or_hm_time $offset] != 2} { + #RFC3339 indicates offset can be specified as hh:mm or Z - not hh:mm:ss + return 0 + } + } else { + #tail has no +/-, only valid if fraction digits + #toml-test invalid/datetime/second-trailing-dot + if {![string is digit -strict $tail]} { return 0 } } } else { set tail [string range $tail 0 end-1] #expect tail nnnn (from hh:mm::ss.nnnnZ) - #had a dot and a zZ - no other offset valid (?) + #had a dot and a zZ if {![string is digit -strict $tail]} { return 0 } @@ -2970,8 +3539,10 @@ namespace eval tomlish::utils { } else { #no dot (fraction of second) if {[regexp {(.*)[+-](.*)} $str _match hms offset]} { - #validate offset - if {![_is_hms_or_hm_time $offset]} { + #validate offset + #offset of +Z or -Z not valid + if {[_is_hms_or_hm_time $offset] != 2} { + #offset is not of required form hh:mm return 0 } } else { @@ -2994,7 +3565,45 @@ namespace eval tomlish::utils { return 0 } } - proc is_localtime {str} { + + proc is_date-local {str} { + set matches [regexp -all {[0-9\-]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) + if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { + return 0 + } + if {$m > 12 || $m == 0} { + return 0 + } + switch -- [expr {$m}] { + 1 - 3 - 5 - 7 - 8 - 10 - 12 { + if {$d > 31 || $d == 0} { + return 0 + } + } + 2 { + if {$d > 29 || $d == 0} { + return 0 + } + if {$d == 29} { + #leapyear check + if {[catch {clock scan $str -format %Y-%m-%d} errM]} { + return 0 + } + } + } + 4 - 6 - 9 - 11 { + if {$d > 30 || $d == 0} { + return 0 + } + } + } + return 1 + } + proc is_time-local {str} { #time of day without any relation to a specific day or any offset or timezone set numchars [tcl::string::length $str] if {[regexp -all {[0-9\.:]} $str] == $numchars} { @@ -3023,9 +3632,26 @@ namespace eval tomlish::utils { return 0 } } - - #review + proc is_datetime-local {str} { + set norm [string map {" " T} $str] + lassign [split $norm T] dp tp + if {$dp eq "" || $tp eq ""} {return 0} + if {![is_date-local $dp]} {return 0} + if {![is_timepart $tp]} {return 0} + if {![is_time-local $tp]} {return 0} + return 1 + } proc is_datetime {str} { + set norm [string map {" " T} $str] + lassign [split $norm T] dp tp + if {$dp eq "" || $tp eq ""} {return 0} + if {![is_date-local $dp]} {return 0} + if {![is_timepart $tp]} {return 0} + if {[is_time-local $tp]} {return 0} + return 1 + } + #review + proc is_date_or_time_or_datetime {str} { #Essentially RFC3339 formatted date-time - but: #1) allowing seconds to be omitted (:00 assumed) #2) T may be replaced with a single space character TODO - parser support for space in datetime! @@ -3073,7 +3699,7 @@ namespace eval tomlish::utils { if {[string first T $str] > -1} { lassign [split $str T] datepart timepart - if {![is_datepart $datepart]} { + if {![is_date-local $datepart]} { return 0 } if {![is_timepart $timepart]} { @@ -3083,7 +3709,7 @@ namespace eval tomlish::utils { #either a datepart or a localtime #spec: "If you include only the time portion of an RFC 3339 formatted date-time, it will represent that time of day # without any relation to a specific day or any offset or timezone." - if {!([is_datepart $str] || [is_localtime $str])} { + if {!([is_date-local $str] || [is_time-local $str])} { return 0 } } @@ -6029,7 +6655,7 @@ namespace eval tomlish::huddle { set h [huddle::json::json2huddle parse $json] } proc from_dict {d} { - + error "tomlish::huddle::from_dict unimplemented" } #raw - strings must already be processed into values suitable for json e.g surrogate pair escaping @@ -6625,8 +7251,40 @@ namespace eval tomlish::dict { set testtype integer set dval [expr {$dval}] ;#convert e.g 0xDEADBEEF to 3735928559 } - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - FLOAT - BOOL { - #DDDD + FLOAT - BOOL { + set testtype [string tolower $dtype] + } + DATE-LOCAL { + set testtype date-local + } + TIME-LOCAL { + if {[tomlish::utils::_is_hms_or_hm_time $dval] == 2} { + #add seconds for sending to json + set dval "${dval}:00" + } + set testtype time-local + } + DATETIME - DATETIME-LOCAL { + #we expect it to be basically well formed here - this is not validation - just adding possible missing seconds + if {![regexp {([tT\ ])} $dval _ dsep]} { + return -code error -errorcode {TOJSON SYNTAX INVALIDDATE} "Unable to process $dtype '$dval' - missing RFC3339 separator space or T" + } + lassign [split $dval $dsep] dp tail + + #toml allows HH:MM without seconds - but we need to add seconds 00 when passing to external systems + if {![tomlish::utils::is_time-local $tail]} { + #there is some offset component. We aren't checking its syntax here (presumed done when dict building) + regexp {([\+\-zZ])} $tail _ tsep ;#keep tsep for rebuilding + lassign [split $tail $tsep] tp offset ;#offset may be empty if z or Z + } else { + set tp $tail + set tsep "" + set offset "" + } + if {[tomlish::utils::_is_hms_or_hm_time $tp] == 2} { + #need to add seconds + set dval "${dp}${dsep}${tp}:00${tsep}${offset}" + } set testtype [string tolower $dtype] } STRING - MULTISTRING { @@ -6644,10 +7302,6 @@ namespace eval tomlish::dict { #} set dval [tomlish::utils::rawstring_to_jsonstring $dval] } - MULTILITERAL { - #todo - escape newlines for json? - set testtype string - } default { error "convert_typeval_to_tomltest unhandled type $dtype" } @@ -6882,7 +7536,7 @@ namespace eval tomlish::dict { lappend dottedtables_defined $dottedsuper_refpath #ensure empty tables are still represented in the datastructure - tomlish::dict::path::set_endpoint datastructure $dottedsuper_refpath {} ;#set to empty subdict + tomlish::dict::path::setleaf datastructure $dottedsuper_refpath {} 0;#set to empty subdict } else { #added for fixed assumption set ttype [dict get $tablenames_info $dottedsuper_refpath ttype] @@ -6935,7 +7589,7 @@ namespace eval tomlish::dict { #'create' the table dict set tablenames_info $dottedkey_refpath ttype dottedkey_table #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list - tomlish::dict::path::set_endpoint datastructure $dottedkey_refpath {} + tomlish::dict::path::setleaf datastructure $dottedkey_refpath {} 0 lappend dottedtables_defined $dottedkey_refpath # @@ -6994,7 +7648,7 @@ namespace eval tomlish::dict { #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_typeval can distinguish tomlish::log::debug "_process_tomlish_dottedkey>>> context:$context_refpath dottedkey $dottedkeyname kv: $keyval_dict" - tomlish::dict::path::set_endpoint datastructure $fullkey_refpath $keyval_dict + tomlish::dict::path::setleaf datastructure $fullkey_refpath $keyval_dict 0 #remove ? #if {![tomlish::dict::is_typeval $keyval_dict]} { @@ -7015,8 +7669,17 @@ namespace eval tomlish::dict { #} return [dict create dottedtables_defined $dottedtables_defined] } + + #tomlish::dict::from_tomlish is a *basic* programmatic datastructure for accessing the data. # produce a dictionary of keys and values from a tomlish tagged list. + # ---------------------------------------------------------------- + # NOTE: + # can instead produce a list if passed an ARRAY at toplevel + # can produce a single value if passed a MULTISTRING or MULTILIST at toplevel + # These are fragments of tomlish used in recursive calls. + # Such fragments don't represent valid tomlish that can be converted to a toml doc. + # ---------------------------------------------------------------- # dict::from_tomlish is primarily for read access to 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. @@ -7036,7 +7699,7 @@ namespace eval tomlish::dict { # versus #[Data] #temps = [{cpu = 79.5, case = 72.0}] - proc from_tomlish {tomlish} { + proc from_tomlish {tomlish {returnextra 0}} { package require dictn #keep track of which tablenames have already been directly defined, @@ -7099,13 +7762,17 @@ namespace eval tomlish::dict { #value is a dict with keys: ttype, tdefined } + if {![string is list $tomlish]} { + error "tomlish::dict::from_tomlish Supplied value for tomlish does not appear to be a tomlish list. Use tomlish::from_toml to get a tomlish list from toml." + } + log::info "---> dict::from_tomlish processing '$tomlish'<<<" set items $tomlish foreach lst $items { if {[lindex $lst 0] ni $::tomlish::tags} { - error "supplied list 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" + error "tomlish::dict::from_tomlish supplied list 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" } } @@ -7121,12 +7788,13 @@ namespace eval tomlish::dict { #puts "...> item:'$item' tag:'$tag'" switch -exact -- $tag { KEY - DQKEY - SQKEY - INT - FLOAT - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - STRING - LITERAL { - #why would we get individual key item as opposed to DOTTEDKEY? + #we don't require invalid tomlish fragments with these keys in our direct recursion + #(we do support ARRAY, MULTISTING, and MULTILITERAL tomlish fragments below) error "tomlish::dict::from_tomlish error: invalid tag: $tag. At the toplevel, from_tomlish can only process WS NEWLINE COMMENT and compound elements DOTTEDKEY TABLE TABLEARRAY ITABLE MULTILITERAL MULTISTRING" } DOTTEDKEY { - #toplevel dotted key - set dkinfo [_process_tomlish_dottedkey $item] + #toplevel dotted key empty context_refpath + set dkinfo [_process_tomlish_dottedkey $item {}] lappend dottedtables_defined {*}[dict get $dkinfo dottedtables_defined] #at any level - we don't expect any more DOTTEDKEY records in a tomlish structure after TABLE or TABLEARRAY are encountered #as those records should encapsulate their own dottedkeys @@ -7221,7 +7889,7 @@ namespace eval tomlish::dict { dict set tablenames_info $tablearray_refpath ttype header_tablearray #dict set datastructure {*}$norm_segments [list type ARRAY value {}] #create array along with empty array-item at position zero - tomlish::dict::path::set_endpoint datastructure $tablearray_refpath [list type ARRAY value {{}}] + tomlish::dict::path::setleaf datastructure $tablearray_refpath [list type ARRAY value {{}}] 0 set arrayitem_refpath [list {*}$tablearray_refpath 0] #set ARRAY_ELEMENTS [list] } else { @@ -7375,7 +8043,7 @@ namespace eval tomlish::dict { dict set tablenames_info $refpath ttype unknown_header #ensure empty tables are still represented in the datastructure #dict set datastructure {*}$supertable [list] - tomlish::dict::path::set_endpoint datastructure $refpath {} + tomlish::dict::path::setleaf datastructure $refpath {} 0 } else { #supertable has already been created - and may be defined - but even if defined we can add subtables unless it is of type itable if {[dict get $tablenames_info $refpath ttype] eq "header_tablearray"} { @@ -7420,7 +8088,7 @@ namespace eval tomlish::dict { #We are 'defining' this table's keys and values here (even if empty) #dict set datastructure {*}$norm_segments [list] ;#ensure table still represented in datastructure even if we add no keyvals here - tomlish::dict::path::set_endpoint datastructure $table_refpath {} ;#ensure table still represented in datastructure even if we add no keyvals here + tomlish::dict::path::setleaf datastructure $table_refpath {} 0;#ensure table still represented in datastructure even if we add no keyvals here } else { if {[dict get $tablenames_info $table_refpath ttype] eq "header_tablearray"} { #e.g tomltest invalid/table/duplicate-table-array2 @@ -7492,6 +8160,7 @@ namespace eval tomlish::dict { } } ARRAY { + #invalid at toplevel of a 'complete' tomlish structure - but we support it here for recursive fragment processing #arrays in toml are allowed to contain mixtures of types set datastructure [list] log::debug "--> processing array: $item" @@ -7540,6 +8209,8 @@ namespace eval tomlish::dict { } } MULTILITERAL { + #Not for toplevel of complete tomlish - (recursive fragment processing) + #triple squoted string #first newline stripped only if it is the very first element #(ie *immediately* following the opening delims) @@ -7583,6 +8254,7 @@ namespace eval tomlish::dict { set datastructure $stringvalue } MULTISTRING { + #Not for toplevel of complete tomlish - (recursive fragment processing) #triple dquoted string log::debug "---> tomlish::dict::from_tomlish processing multistring: $item" set stringvalue "" @@ -7696,82 +8368,394 @@ namespace eval tomlish::dict { } } } - return $datastructure + if {!$returnextra} { + return $datastructure + } else { + return [dict create datastructure $datastructure tablenames_info $tablenames_info] + } + } +} +namespace eval tomlish::path { + namespace export {[a-z]*}; # Convention: export all lowercase + + set test_tomlish [tomlish::from_toml { } #comment {z=1} {x.y=2 #xy2} {[[shop.product]] #product1} {x=[ #array1} {11 #val1} {, 12 #val2} {]} {[unrelated.' etc ']} {a.b={c=666}} {a.x={}} {[[shop.product]]} {x="test"} {[shop]} {name="myshop"}] + + proc get {tomlish {path {}}} { + if {$path eq ""} { + return $tomlish + } + if {[string index $path 0] in [list . "\["]} { + set path [tomlish::utils::jq_to_path $path] + } + + #at the cost of some performance, sanity check that the tomlish is valid + if {[catch {tomlish::to_dict $tomlish} d]} { + error "tomlish::path::get error supplied tomlish is malformed\nerrmsg: $d" + } + #since we have the dict - test the path is valid + if {![tomlish::dict::path::exists $d $path]} { + error "tomlish::path::get - path \"$path\" not found in tomlish $tomlish" + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + set tomlish [lrange $tomlish 1 end] + } + ::set pathsofar [list] + ::set tomlitems [list] ;#reducing set. 2 element list {keypath itemlist} + foreach record $tomlish { + lappend tomlitems [list {} [list $record]] ;#root records + } + + ::set dictsubpath [list] ;#reset at every index encounter? + foreach p $path { + ::lappend pathsofar $p + set sublist [list] + if {[string range $p 0 1] eq "@@"} { + set realsearchkey [string range $p 2 end] + lappend dictsubpath $realsearchkey + foreach path_items $tomlitems { + lassign $path_items subpath tlist + lappend subpath $realsearchkey + foreach item $tlist { + set tp [lindex $item 0] + switch -- $tp { + WS - NEWLINE - COMMENT { + } + DOTTEDKEY { + #can occur at toplevel (before others) or within other elements + set keyinfo [tomlish::get_dottedkey_info $item] + set keys_raw [dict get $keyinfo keys_raw] + puts stderr "subpath:$subpath -->DOTTEDKEY keys_raw: $keys_raw" + #may not be enough keys_raw for subpath - but there could be further ITABLES to continue the dict further + set prefixparts [lrange $keys_raw 0 [llength $subpath]-1] + set is_kmatch 1 ;#default assumption only + foreach dsub $subpath kpart $prefixparts { + if {$dsub ne $kpart} { + set is_kmatch 0 + } + } + if {$is_kmatch} { + if {[llength $keys_raw] == [llength $subpath]} { + set subpath [list] + #e.g {DOTTEDKEY {{KEY xxx}} = {WS { }} {STRING blah}} + lappend sublist [list $subpath [lrange $item 3 end]] + } else { + lappend sublist [list $subpath [list $item]] + } + } + } + ITABLE { + #subelement only + set itablechildren [lrange $item 1 end] + puts stderr "subpath:$subpath -->ITABLE records: $itablechildren" + set nextpath [lmap v $subpath {string cat @@ $v}] + set results [tomlish::path::get $itablechildren $nextpath] + set subpath [list] + puts "--> lappending [list $subpath $results]" + lappend sublist [list $subpath $results] + } + TABLEARRAY { + #toplevel only + set fulltablename [lindex $item 1] + set normalise 1 + set tparts [tomlish::toml::tablename_split $fulltablename $normalise] + if {[llength $tparts] < [llength $subpath]} {continue} ;#not enough parts to satisfy current subpath query + set prefixparts [lrange $tparts 0 [llength $subpath]-1] + set is_tmatch 1 ;#default assumption only + foreach dsub $subpath tpart $prefixparts { + if {$dsub ne $tpart} { + set is_tmatch 0 + } + } + #TODO reference arrays + if {$is_tmatch} { + if {[llength $tparts] == [llength $subpath]} { + set subpath [list] + lappend sublist [list $subpath [lrange $item 2 end]] + } else { + #TODO + set subpath 0 + lappend sublist [list $subpath [list $item]] ;#add entire TABLE line + } + } + } + TABLE { + #toplevel only + set fulltablename [lindex $item 1] + set normalise 1 + set tparts [tomlish::toml::tablename_split $fulltablename $normalise] + if {[llength $tparts] < [llength $subpath]} {continue} ;#not enough parts to satisfy current subpath query + set prefixparts [lrange $tparts 0 [llength $subpath]-1] + set is_tmatch 1 ;#default assumption only + foreach dsub $subpath tpart $prefixparts { + if {$dsub ne $tpart} { + set is_tmatch 0 + } + } + if {$is_tmatch} { + if {[llength $tparts] == [llength $subpath]} { + set subpath [list] + lappend sublist [list $subpath [lrange $item 2 end]] + } else { + #leave subpath + lappend sublist [list $subpath [list $item]] ;#add entire TABLE line + } + } + } + ARRAY { + #subelement only + } + + } + } + } + } else { + #index + #will never occur at toplevel (dict::path::exists already ruled it out) + foreach path_items $toml_items { + lassign $path_items subpath $tlist + set tp [lindex $tlist 0] + switch -- $tp { + ARRAY { + } + } + } + } + #temp + puts stdout "pathsofar: $pathsofar" + puts stdout [punk::lib::showdict -roottype list $sublist] + set tomlitems $sublist + } + + #REVIEW + if {[llength $tomlitems] == 1} { + return [lindex $tomlitems 0 1] + } + set result [list] + foreach i $tomlitems { + lappend result [lindex $i 1] + } + return $result + #return [lindex $tomlitems 1] } + } namespace eval tomlish::dict::path { - #access tomlish dict structure + + #access tomlish dict structure namespace export {[a-z]*}; # Convention: export all lowercase - #access with path such as: @@k @@k 0 @@k end where dict keys marked with @@ and plain values are list indices into in {type ARRAY value } - #leaf elements returned as structured {type value } + #access with path such as: @@k @@k 0 @@k end where dict keys marked with @@ and plain values are list indices into in {type ARRAY value } + #leaf elements returned as structured {type value } proc get {dictval {path {}}} { if {$path eq ""} { return $dictval } + if {[string index $path 0] in [list . "\["]} { + set path [tomlish::utils::jq_to_path $path] + } + ::set data $dictval ::set pathsofar [list] + ::set i 0 foreach p $path { ::lappend pathsofar $p if {[string range $p 0 1] eq "@@"} { + #dict key ::set data [dict get $data [string range $p 2 end]] } else { - if {![tomlish::dict::is_typeval $data]} { - error "tomlish::dict::path::get error bad path $path. Attempt to access table as array at subpath $pathsofar." - } - if {[dict get $data type] ne "ARRAY"} { - error "tomlish::dict::get error bad path $path. Subpath $pathsofar is not an array." + #ARRAY or raw list index + if {[llength $pathsofar] > 1 && [string trim [lindex $pathsofar $i-1]] eq ""} { + #previous path was query for entire list - result is a raw list, not a dict + if {[string trim $p] eq ""} { + #review - multiple {[]} in a row in the path is pretty suspicious - raise error + error "tomlish::dict::path::get error - multiple empty indices in a row not supported" + } + ::set data [lindex $data $p] + } else { + if {![tomlish::dict::is_typeval $data]} { + error "tomlish::dict::path::get error bad path $path. Attempt to access table or other value as array at subpath $pathsofar." + } + if {[dict get $data type] ne "ARRAY"} { + error "tomlish::dict::get error bad path $path. Subpath $pathsofar is not an array." + } + ::set arrdata [dict get $data value] + #when $p is empty string (or whitespace) - lindex returns entire list (or empty list) + # - this corresponds to jq: {[]} or path {""} + ::set data [lindex $arrdata $p] } - ::set arrdata [dict get $data value] - ::set data [lindex $arrdata $p] } + incr i } return $data } + proc exists {dictval path} { + #completely empty path considered to exist - review + if {[string index $path 0] in [list . {[}]} { + set path [tomlish::utils::jq_to_path $path] + } ::set data $dictval ::set pathsofar [list] ::set exists 1 + ::set i 0 foreach p $path { ::lappend pathsofar $p if {[string range $p 0 1] eq "@@"} { + #dict key ::set k [string range $p 2 end] if {![dict exists $data $k]} { return 0 } ::set data [dict get $data $k] } else { - if {![tomlish::dict::is_typeval $data]} { - return 0 + #ARRAY or raw list index + if {[llength $pathsofar] > 1 && [string trim [lindex $pathsofar $i-1]] eq ""} { + #previous path was query for entire list - result is not a dict + if {[string trim $p] eq ""} { + #review - multiple {[]} in a row in the path is pretty suspicious - raise error + error "tomlish::dict::path::exists error - multiple empty indices in a row not supported" + #or just leave data as is? + } else { + ::set intp [tomlish::system::lindex_resolve_basic $data $p] + if {$intp == -1} { + return 0 + } + ::set data [lindex $data $p] + } + } else { + if {![tomlish::dict::is_typeval $data]} { + return 0 + } + if {[dict get $data type] ne "ARRAY"} { + return 0 + } + #special case for empty path syntax {jq: [] path: ""} meaning retrieve all elements in list + ::set arrdata [dict get $data value] + if {[string trim $p] eq ""} { + #we have confirmed above it is an ARRAY - we consider an empty list to exist. + #UUU + ::set data $arrdata + } else { + #for 'exists' we need to avoid lindex returning empty string for out of bounds + ::set intp [tomlish::system::lindex_resolve_basic $arrdata $p] ;#handle index math (end-1 etc) + if {$intp == -1} { + #out of bounds + return 0 + } + ::set data [lindex $arrdata $p] + } } - if {[dict get $data type] ne "ARRAY"} { - return 0 + } + incr i + } + return $exists + } + + + #raise error for invalid + proc validate_typeval {typeval} { + set valtype [dict get $typeval type] + set rawval [dict get $typeval value] + switch -- $valtype { + INT { + if {![tomlish::utils::is_int $rawval]} { + return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml int: '$rawval'" } - ::set arrdata [dict get $data value] - ::set intp [tomlish::system::lindex_resolve_basic $arrdata $p] ;#handle index math (end-1 etc) - if {$intp == -1} { - #out of bounds - return 0 + } + BOOL { + #toml only accepts lower case true and false + #review + if {$rawval ni {true false}} { + return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml boolean (true|false): '$rawval'" + } + } + FLOAT { + if {![tomlish::utils::is_float $rawval]} { + return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml float: '$rawval'" + } + } + DATETIME { + #review - accept even when more specific types apply? + if {![tomlish::utils::is_datetime]} { + return -code error -errorcode {TOML TYPE NOT_DATETIME} "validate_typeval value is not a valid toml datetime: '$rawval'" + } + } + DATETIME-LOCAL { + if {![tomlish::utils::is_datetime-local]} { + return -code error -errorcode {TOML TYPE NOT_DATETIME-LOCAL} "validate_typeval value is not a valid toml datetime-local: '$rawval'" + } + } + DATE-LOCAL { + if {![tomlish::utils::is_date-local]} { + return -code error -errorcode {TOML TYPE NOT_DATE-LOCAL} "validate_typeval value is not a valid toml date-local: '$rawval'" + } + } + TIME-LOCAL { + if {![tomlish::utils::is_time-local]} { + return -code error -errorcode {TOML TYPE NOT_TIME-LOCAL} "validate_typeval value is not a valid toml time-local: '$rawval'" + } + } + ARRAY { + if {$rawval eq ""} { + return + } + foreach el $rawval { + validate_typeval $el + } + } + STRING { + if {![tomlish::utils::inner_Bstring_is_valid_toml $rawval]} { + return -code error -errorcode {TOML TYPE NOT_BSTRING} "validate_typeval value is not a valid toml basic string: '$rawval'" } - ::set data [lindex $arrdata $p] + } + MULTISTRING { + #multistring as a single value + #UUU + if {![tomlish::utils::inner_MultiBstring_is_valid_toml $rawval]} { + return -code error -errorcode {TOML TYPE NOT_MLBSTRING} "validate_typeval value is not a valid toml multistring: '$rawval'" + } + } + LITERAL { + #todo? + } + MULTILITERAL { + #? + } + default { + return -code error -errorcode {TOML TYPE UNRECOGNISED} "validate_typeval does not recognise type '$valtype'" } } - return $exists } #a restricted analogy of 'dictn set' - #set 'endpoints' - don't create intermediate paths + #set 'leaf' values only - don't create intermediate paths # can replace an existing dict with another dict # can create a key when key at tail end of path is a key (ie @@keyname, not index) # can replace an existing {type value value } # with added restriction that if is ARRAY the new must also be ARRAY - proc set_endpoint {dictvariable path value} { + + package require struct::list + proc setleaf {dictvariable path value {validate 1}} { + if {[string index $path 0] in [list . {[}]} { + set path [tomlish::utils::jq_to_path $path] + } + upvar $dictvariable dict_being_edited + if {![info exists dict_being_edited]} { + error "tomlish::dict::path::setleaf error - supplied value for 'dictvariable' doesn't seem to be the name of an existing variable" + } ::set data $dict_being_edited ::set pathsofar [list] if {!([tomlish::dict::is_typeval $value] || [tomlish::dict::is_typeval_dict $value 0])} { #failed check of supplied value as basic type, or a sub-dict structure (not checking arrays) - error "tomlish::dict::path::set_endpoint error - value must already be in the tomlish form {type value } or be a dict with such forms as leaves" + error "tomlish::dict::path::setleaf error - value must already be in the tomlish form {type value } or be a dict with such forms as leaves" + } + if {$validate && [tomlish::dict::is_typeval $value]} { + #validate value element of $value is correct for type element + if {[catch {validate_typeval $value} errM]} { + return -code error -errorcode {TOMLISH VALIDATION TYPEFAIL} $errM + } } foreach p $path { ::lappend pathsofar $p @@ -7783,28 +8767,28 @@ namespace eval tomlish::dict::path { #} ::set varname v[incr v] - if {$pathsofar eq $path} { - #see if endpoint of the path given already exists + if {[struct::list equal $pathsofar $path]} { + #see if leaf of the path given already exists if {[dict exists $data $k]} { ::set endpoint [dict get $data $k] if {[tomlish::dict::is_typeval $endpoint]} { set existing_tp [dict get $endpoint type] if {![tomlish::dict::is_typeval $value]} { - error "tomlish::dict::path::set_endpoint error Unable to overwrite subpath '$pathsofar' which is of type $existing_tp with sub-dict. Supplied value not {type value value val } with sub-dict: $value" + error "tomlish::dict::path::setleaf error path '$path'. Cannot overwrite {type val } with sub-dict: $value" } switch -- [dict get $endpoint type] { ARRAY { #disallow overwriting array - unless given value is an ARRAY? REVIEW if {[dict get $value type] ne "ARRAY"} { - error "tomlish::dict::path::set_endpoint error bad path '$path'. Cannot overwrite array with non-array: $value" + error "tomlish::dict::path::setleaf error bad path '$path'. Cannot overwrite array with non-array: $value" } } default { @@ -7855,9 +8839,9 @@ namespace eval tomlish::dict::path { } } } else { - #endpoint is a typeval dict not a plain typeval - only allow overwrite with a typeval dict + #leaf is a typeval dict not a plain typeval - only allow overwrite with a typeval dict if {![tomlish::dict::is_typeval_dict $value 0]} { - error "tomlish::dict::path::set_endpoint error path '$path'. Cannot overwrite sub-dict (size: [dict size $endpoint]) with non sub-dict: $value" + error "tomlish::dict::path::setleaf error path '$path'. Cannot overwrite sub-dict (size: [dict size $endpoint]) with non sub-dict: $value" } } ::set $varname $value @@ -7867,7 +8851,7 @@ namespace eval tomlish::dict::path { ::set arrdata [dict get $data value] set idx [tomlish::system::lindex_resolve_basic $arrdata $p] if {$idx == -1} { - error "tomlish::dict::path::set_endpoint error bad path '$path'. No existing element at $p" + error "tomlish::dict::path::setleaf error bad path '$path'. No existing element at $p" } ::set data [lindex $arrdata $p] ::set $varname $data @@ -7897,7 +8881,7 @@ namespace eval tomlish::dict::path { if {[string match @@* $k]} { #dict key #dict set $nextvarname $k $newval - set_endpoint $nextvarname [list $k] $newval + setleaf $nextvarname [list $k] $newval 0 } else { #list index ::set nextarr [dict get $nextval value] @@ -7913,6 +8897,9 @@ namespace eval tomlish::dict::path { #path must be to a {type ARRAY value } #REVIEW - how to lappend to deep mixed dict/array structure without rewriting whole datastructure? proc lappend {dictvariable path args} { + if {[string index $path 0] in [list . {[}]} { + set path [tomlish::utils::jq_to_path $path] + } upvar $dictvariable dict_being_edited ::set data $dict_being_edited ::set pathsofar [list] @@ -7933,7 +8920,7 @@ namespace eval tomlish::dict::path { } ::set varname v[incr v] - if {$pathsofar eq $path} { + if {[struct::list equal $pathsofar $path]} { #see if endpoint of the path given is an ARRAY ::set endpoint [dict get $data $k] if {![tomlish::dict::is_typeval $endpoint]} { @@ -7961,7 +8948,7 @@ namespace eval tomlish::dict::path { error "tomlish::dict::path::lappend error bad path $path. Subpath $pathsofar is not an array." } ::set varname v[incr v] - if {$pathsofar eq $path} { + if {[struct::list equal $pathsofar $path]} { if {[dict get $data type] ne "ARRAY"} { error "tomlish::dict::path::lappend error bad path $path. Parent path is not an array." } @@ -8160,6 +9147,8 @@ tcl::namespace::eval tomlish::app { #review chan configure $ch_input -translation lf + chan configure $ch_output -translation lf + if {[catch { set json [read $ch_input] }]} { @@ -8291,6 +9280,25 @@ namespace eval tomlish::system { } } + #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features + #safe in that we don't evaluate the expression as a string. + proc offset_expr {expression} { + #required for tcl < 8.7 range command (lseq not available) + set expression [tcl::string::map {_ {}} $expression] + if {[tcl::string::is integer -strict $expression]} { + return [expr {$expression}] + } + if {[regexp {(.*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { + if {$op eq "-"} { + return [expr {$a - $b}] + } else { + return [expr {$a + $b}] + } + } else { + error "bad expression '$expression': must be integer?\[+-\]integer?" + } + } + if {[info commands ::lseq] ne ""} { #tcl 8.7+ lseq significantly faster, especially for larger ranges #The internal rep can be an 'arithseries' with no string representation diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 5b45b2bc..c7207cc0 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -103,7 +103,9 @@ tcl::namespace::eval punk::aliascore { #use absolute ns ie must be prefixed with :: #single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased - #functions must be in export list of their source namespace + #functions should generally be covered by one of the export patterns of their source namespace + # - if they are not - e.g (separately loaded ensemble command ?) + # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. set aliases [tcl::dict::create\ val ::punk::pipe::val\ aliases ::punk::lib::aliases\ @@ -122,8 +124,8 @@ tcl::namespace::eval punk::aliascore { stripansi ::punk::ansi::ansistrip\ ansiwrap ::punk::ansi::ansiwrap\ colour ::punk::console::colour\ - ansi ::punk::console::ansi\ color ::punk::console::colour\ + ansi ::punk::console::ansi\ a? ::punk::console::code_a?\ A? {::punk::console::code_a? forcecolor}\ a+ ::punk::console::code_a+\ @@ -132,6 +134,7 @@ tcl::namespace::eval punk::aliascore { A {::punk::console::code_a forcecolour}\ smcup ::punk::console::enable_alt_screen\ rmcup ::punk::console::disable_alt_screen\ + config ::punk::config\ ] #*** !doctools @@ -153,6 +156,35 @@ tcl::namespace::eval punk::aliascore { # return "ok" #} + proc _is_exported {ns cmd} { + set exports [::tcl::namespace::eval $ns [list namespace export]] + set is_exported 0 + foreach p $exports { + if {[string match $p $cmd]} { + set is_exported 1 + break + } + } + return $is_exported + } + + #_nsprefix accepts entire command - not just an existing namespace for which we want the parent + proc _nsprefix {{nspath {}}} { + #maintenance: from punk::ns::nsprefix - (without unnecessary nstail) + #normalize the common case of :::: + set nspath [string map {:::: ::} $nspath] + set rawprefix [string range $nspath 0 end-[string length [namespace tail $nspath]]] + if {$rawprefix eq "::"} { + return $rawprefix + } else { + if {[string match *:: $rawprefix]} { + return [string range $rawprefix 0 end-2] + } else { + return $rawprefix + } + } + } + #todo - options as to whether we should raise an error if collisions found, undo aliases etc? proc init {args} { set defaults {-force 0} @@ -195,6 +227,7 @@ tcl::namespace::eval punk::aliascore { error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" } + set failed [list] set tempns ::temp_[info cmdcount] ;#temp ns for renames dict for {a cmd} $aliases { #puts "aliascore $a -> $cmd" @@ -206,16 +239,36 @@ tcl::namespace::eval punk::aliascore { } else { if {[tcl::info::commands $cmd] ne ""} { #todo - ensure exported? noclobber? - if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { + set container_ns [_nsprefix $cmd] + set cmdtail [tcl::namespace::tail $cmd] + set was_exported 1 ;#assumption + if {![_is_exported $container_ns $cmdtail]} { + set was_exported 0 + set existing_exports [tcl::namespace::eval $container_ns [list ::namespace export]] + tcl::namespace::eval $container_ns [list ::namespace export $cmdtail] + } + if {[tcl::namespace::tail $a] eq $cmdtail} { #puts stderr "importing $cmd" - tcl::namespace::eval :: [list namespace import $cmd] + try { + tcl::namespace::eval :: [list ::namespace import $cmd] + } trap {} {emsg eopts} { + lappend failed [list alias $a target $cmd errormsg $emsg] + } } else { #target command name differs from exported name #e.g stripansi -> punk::ansi::ansistrip #import and rename #puts stderr "importing $cmd (with rename to ::$a)" - tcl::namespace::eval $tempns [list namespace import $cmd] - catch {rename ${tempns}::[namespace tail $cmd] ::$a} + try { + tcl::namespace::eval $tempns [list ::namespace import $cmd] + } trap {} {emsg eopst} { + lappend failed [list alias $a target $cmd errormsg $emsg] + } + catch {rename ${tempns}::$cmdtail ::$a} + } + #restore original exports + if {!$was_exported} { + tcl::namespace::eval $container_ns [list ::namespace export -clear {*}$existing_exports] } } else { interp alias {} $a {} {*}$cmd @@ -223,7 +276,7 @@ tcl::namespace::eval punk::aliascore { } } #tcl::namespace::delete $tempns - return [dict create aliases [dict keys $aliases] unchanged $ignore_aliases changed $conflicts] + return [dict create aliases [dict keys $aliases] existing $existing ignored $ignore_aliases changed $conflicts failed $failed] } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 61a454fa..fcbf6ada 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3357,9 +3357,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend PUNKARGS [list { @id -id ::punk::ansi::ansiwrap @cmd -name punk::ansi::ansiwrap -help\ - "Wrap a string with ANSI codes from + {Wrap a string with ANSI codes from supplied codelist(s) followed by trailing - ANSI reset. + ANSI reset. The wrapping is done such that + after every reset in the supplied text, the + default goes back to the supplied codelist. + e.g1 in the following + ansiwrap red bold "rrr[a+ green]ggg[a]rrr" + both strings rrr will be red & bold + + e.g2 bolding and underlining specific text whilst dimming the rest + ansiwrap dim [string map [list test [ansiwrap bold underline test]] "A test string"] + + e.g3 reverse render a complex ansi substring + ansiwrap reverse [textblock::periodic] Codes are numbers or strings as indicated in the output of the colour information @@ -3372,41 +3383,172 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu For finer control use the a+ and a functions eg - set x \"[a+ red]text [a+ bold]etc[a]\" - " + set x "[a+ red]text [a+ bold]etc[a]" + } @leaders -min 0 -max -1 codelist -multiple 1 -default {} -type list -help\ "ANSI names/ints as understood by 'a?' (Not actual ANSI as output by a+) These can be supplied individually or as a list or lists" + @opts + -rawansi -type ansi -default "" + -resetcodes -type list -default {reset} + -rawresets -type ansi -default "" + -fullcodemerge -type boolean -default 0 -help\ + "experimental" + -overridecodes -type list -default {} @values -min 1 -max 1 text -type string -help\ "String to wrap with ANSI (SGR)" }] - #proc ansiwrap {codes text} { - # return [a {*}$codes]$text[a] - #} - proc ansiwrap2 {args} { - set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] - set codelists [dict get $argd leaders codelist] - set text [dict get $argd values text] - set codes [concat {*}$codelists] ;#flatten - return [a {*}$codes]$text[a] - } proc ansiwrap {args} { if {[llength $args] < 1} { - #minimal args parsing - unhappy path only + #throw to args::parse to get friendly error/usage display punk::args::parse $args withid ::punk::ansi::ansiwrap return } - set text [lindex $args end] - set codelists [lrange $args 0 end-1] + #we know there are no valid codes that start with - + if {[lsearch [lrange $args 0 end-1] -*] == -1} { + #no opts + set text [lindex $args end] + set codelists [lrange $args 0 end-1] + set R [a] ;#plain ansi reset + set rawansi "" + set rawresets "" + set fullmerge 0 + set overrides "" + } else { + set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] + lassign [dict values $argd] leaders opts values received solos + set codelists [dict get $leaders codelist] + set text [dict get $values text] + set rawansi [dict get $opts -rawansi] + set R [a+ {*}[dict get $opts -resetcodes]] + set rawresets [dict get $opts -rawresets] + set fullmerge [dict get $opts -fullcodemerge] + set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]] + } + + #note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence. + #there can be SGR unmergeables (due to enhanced underlines) as well as non SGR codes set codes [concat {*}$codelists] ;#flatten - return [a {*}$codes]$text[a] - } + set base [a+ {*}$codes] + if {$rawansi ne ""} { + set rawcodes [punk::ansi::ta::get_codes_single $rawansi] ;#caller may have supplied as [a+ xxx][a+ yyy] + if {$fullmerge} { + set base [punk::ansi::codetype::sgr_merge [list $base {*}$rawcodes]] + } else { + set base [punk::ansi::codetype::sgr_merge_singles [list $base {*}$rawcodes]] + } + } + if {$rawresets ne ""} { + set rawresetcodes [punk::ansi::ta::get_codes_single $rawresets] + if {$fullmerge} { + set R [punk::ansi::codetype::sgr_merge [list $R {*}$rawresetcodes]] + } else { + set R [punk::ansi::codetype::sgr_merge_singles [list $R {*}$rawresetcodes]] + } + } + set codestack [list] + if {[punk::ansi::ta::detect $text]} { + set emit "" + set parts [punk::ansi::ta::split_codes $text] + foreach {pt code} $parts { + switch -- [llength $codestack] { + 0 { + append emit $base$pt$R + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { + append emit $base$pt$R + set codestack [list] + } else { + #append emit [lindex $o_codestack 0]$pt + if {$fullmerge} { + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + } else { + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + } + } + } + default { + if {$fullmerge} { + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + } else { + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + } + } + } + #parts ends on a pt - last code always empty string + if {$code ne ""} { + set c1c2 [tcl::string::range $code 0 1] + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3] + switch -- $leadernorm { + 7CSI - 8CSI { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #todo - make caching is_sgr method + set dup_posns [lsearch -all -exact $codestack $code] + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set o_gx_state on + } + "B" { + set o_gx_state off + } + } + } + default { + #other ansi codes + } + } + append emit $code + } + } + return $emit$R + } else { + return $base$text$R + } + } + proc ansiwrap_naive {codes text} { + return [a_ {*}$codes]$text[a] + } + + #a silly trick... temporary? probably - todo - tests and work on sgr_merge + sgr_merge_singles before relying on this + #when we use sgr_merge_singles on a 'single' containing a non SGR code e.g [5h (inverse) it puts this code at the end of the list + #furthermore - it carries any SGR codes along with it (Can/should we rely on this behaviour??? probably not) REVIEW + #P% ansistring VIEW $s1 + #- ␛[31m␛[?5h + #P% ansistring VIEW [punk::ansi::codetype::sgr_merge_singles [list $s1 [a+ cyan]]] + #- ␛[36m␛[31m␛[?5h + #P% ansistring VIEW [punk::ansi::codetype::sgr_merge [list $s1 [a+ cyan]]] + #- ␛[36m␛[?5h + #we can use this trick to override background and/or foreground colours using ansiwrap - which uses sgr_merge_singles + #Note - this trick is not composable - e.g ansioverride Red [ansiioverride Green [textblock::periodic]] doesn't work as expected. + proc ansioverride2 {args} { + set text [lindex $args end] + set codes [lrange $args 0 end-1] + ansiwrap {*}$codes -rawansi [punk::ansi::enable_inverse] -rawresets [punk::ansi::disable_inverse] $text + } + proc ansireverse {text} { + ansioverride2 normal reverse $text + } proc get_code_name {code} { #*** !doctools @@ -4491,6 +4633,77 @@ tcl::namespace::eval punk::ansi { return 0 } } + + #e.g has_any_effective $str bg fg + proc has_any_effective {str args} { + set singlecodes [punk::ansi::ta::get_codes_single $str] + set mergeinfo [punk::ansi::codetype::sgr_merge_singles $singlecodes -info 1] + foreach t $args { + switch -- $t { + sgr - unmergeable - othercodes { + if {[dict get $mergeinfo $t] ne ""} { + return 1 + } + } + intensity - italic - underline - underextended - blink - reverse - hide - strike - font - gothic - doubleunderline + - proportional - frame_or_circle - ideogram_underline - ideogram_doubleunderline - ideogram_clear - overline - underlinecolour - superscript - subscript + - nosupersub - fg - bg { + if {[dict get $mergeinfo codestate $t] ne ""} { + return 1 + } + } + bold { + if {[dict get $mergeinfo codestate intensity] eq "1"} { + return 1 + } + } + dim { + if {[dict get $mergeinfo codestate intensity] eq "2"} { + return 1 + } + } + default { + error "punk::ansi::ta::has_any_effective invalid type '$t' specified" + } + } + } + return 0 + } + proc has_all_effective {str args} { + set singlecodes [punk::ansi::ta::get_codes_single $str] + set mergeinfo [punk::ansi::codetype::sgr_merge_singles $singlecodes -info 1] + foreach t $args { + switch -- $t { + sgr - unmergeable - othercodes { + if {[dict get $mergeinfo $t] eq ""} { + return 0 + } + } + intensity - italic - underline - underextended - blink - reverse - hide - strike - font - gothic - doubleunderline + - proportional - frame_or_circle - ideogram_underline - ideogram_doubleunderline - ideogram_clear - overline - underlinecolour - superscript - subscript + - nosupersub - fg - bg { + if {[dict get $mergeinfo codestate $t] eq ""} { + return 0 + } + } + bold { + if {[dict get $mergeinfo codestate intensity] ne "1"} { + return 0 + } + } + dim { + if {[dict get $mergeinfo codestate intensity] ne "2"} { + return 0 + } + } + default { + error "punk::ansi::ta::has_any_effective invalid type '$t' specified" + } + } + } + return 1 + } + proc is_gx {code} { #g0 {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} #g1 {(?:\x1b\)0)(?:(?!\x1b\)B).)*\x1b\)B} @@ -4513,6 +4726,7 @@ tcl::namespace::eval punk::ansi { set codestate_empty [tcl::dict::create] tcl::dict::set codestate_empty rst "" ;#0 (or empty) tcl::dict::set codestate_empty intensity "" ;#1 bold, 2 dim, 22 normal + tcl::dict::set codestate_empty shadowed "" ; tcl::dict::set codestate_empty italic "" ;#3 on 23 off tcl::dict::set codestate_empty underline "" ;#4 on 24 off diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.4.tm index 95d5c702..e1256fe4 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.4.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.4.tm @@ -3226,7 +3226,36 @@ tcl::namespace::eval punk::args { form1: parse $arglist ?-flag val?... withid $id form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define" + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " @form -form {withid withdef} @leaders -min 1 -max 1 arglist -type list -optional 0 -help\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm index 5532cb80..f2f85349 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -1,23 +1,109 @@ tcl::namespace::eval punk::config { - variable loaded - variable startup ;#include env overrides - variable running + variable configdata [dict create] ;#key on config names. At least default, startup, running + + #variable startup ;#include env overrides + #variable running + variable punk_env_vars variable other_env_vars variable vars namespace export {[a-z]*} + namespace ensemble create + namespace eval punk {namespace export config} + + proc _homedir {} { + if {[info exists ::env(HOME)]} { + set home [file normalize $::env(HOME)] + } else { + #not available on 8.6? ok will error out here. + set home [file tildeexpand ~] + } + return $home + } + + lappend PUNKARGS [list { + @id -id ::punk::config::dir + @cmd -name punk::config::dir -help\ + "Get the path for the default config folder + Config files are in toml format. + + The XDG_CONFIG_HOME env var is the preferred + choice of location. + A folder under the user's home directory, + at .config/punk/shell is chosen if + XDG_CONFIG_HOME is not configured. + " + @leaders -min 0 -max 0 + @opts + -quiet -type none -help\ + "Suppress warning given when the folder does + not yet exist" + @values -min 0 -max 0 + }] + proc dir {args} { + if {"-quiet" in $args} { + set be_quiet [dict exists $received -quiet] + } + + set was_noisy 0 + + set config_home [punk::config::configure running xdg_config_home] + + set config_dir [file join $config_home punk shell] + + if {!$be_quiet && ![file exists $config_dir]} { + set msg "punk::shell data storage folder at $config_dir does not yet exist." + puts stderr $msg + set was_noisy 1 + } + + if {!$be_quiet && $was_noisy} { + puts stderr "punk::config::dir - call with -quiet option to suppress these messages" + } + return $config_dir + + #if {[info exists ::env(XDG_CONFIG_HOME)]} { + # set config_home $::env(XDG_CONFIG_HOME) + #} else { + # set config_home [file join [_homedir] .config] + # if {!$be_quiet} { + # puts stderr "Environment variable XDG_CONFIG_HOME does not exist - consider setting it if $config_home is not a suitable location" + # set was_noisy 1 + # } + #} + #if {!$be_quiet && ![file exists $config_home]} { + # #parent folder for 'punk' config dir doesn't exist + # set msg "configuration location (XDG_CONFIG_HOME or ~/.config) $config_home does not yet exist" + # append msg \n " - please create it and/or set XDG_CONFIG_HOME env var." + # puts stderr $msg + # set was_noisy 1 + #} + #set config_dir [file join $config_home punk shell] + #if {!$be_quiet && ![file exists $config_dir]} { + # set msg "punk::shell data storage folder at $config_dir does not yet exist." + # append msg \n " It will be created if api_context_save is called without specifying an alternate location." + # puts stderr $msg + # set was_noisy 1 + #} + #if {!$be_quiet && $was_noisy} { + # puts stderr "punk::config::dir - call with -quiet option to suppress these messages" + #} + #return [file join $configdir config.toml] + } #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 configdata + + #variable defaults + #variable startup + #variable running variable punk_env_vars variable punk_env_vars_config variable other_env_vars @@ -108,12 +194,14 @@ tcl::namespace::eval punk::config { #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)]} { + #Typical existing/default value for env(APPDATA) on windows is c:\Users\\AppData\Roaming 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)]} { + #Typical existing/default value for env(APPDATA) on windows is c:\Users\\AppData\Local + set default_xdg_data_home $::env(LOCALAPPDATA) set default_xdg_cache_home $::env(LOCALAPPDATA) set default_xdg_state_home $::env(LOCALAPPDATA) } @@ -133,10 +221,10 @@ tcl::namespace::eval punk::config { } } - set defaults [dict create\ + dict set configdata defaults [dict create\ apps $default_apps\ - config ""\ - configset ".punkshell"\ + config "startup"\ + configset "main"\ scriptlib $default_scriptlib\ color_stdout $default_color_stdout\ color_stdout_repl $default_color_stdout_repl\ @@ -160,7 +248,7 @@ tcl::namespace::eval punk::config { posh_themes_path ""\ ] - set startup $defaults + dict set configdata startup [dict get $configdata 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 @@ -219,9 +307,9 @@ tcl::namespace::eval punk::config { lappend final $p } } - tcl::dict::set startup $varname $final + tcl::dict::set configdata startup $varname $final } else { - tcl::dict::set startup $varname $f + tcl::dict::set configdata startup $varname $f } } } @@ -273,29 +361,44 @@ tcl::namespace::eval punk::config { lappend final $p } } - tcl::dict::set startup $varname $final + tcl::dict::set configdata startup $varname $final } else { - tcl::dict::set startup $varname $f + tcl::dict::set configdata startup $varname $f } } } } + set config_home [dict get $configdata startup xdg_config_home] + + if {![file exists $config_home]} { + puts stderr "punk::config::init creating punk shell config dir: [dir]" + puts stderr "(todo)" + } + + set configset [dict get $configdata defaults configset] + set config [dict get $configdata defaults config] + + set startupfile [file join $config_home $configset $config.toml] + if {![file exists $startupfile]} { + puts stderr "punk::config::init creating punk shell config file: $config for configset: $configset" + puts stderr "(todo)" + } #unset -nocomplain vars #todo set running [tcl::dict::create] - set running [tcl::dict::merge $running $startup] + dict set configdata running [tcl::dict::merge $running [dict get $configdata startup]] } - init #todo proc Apply {config} { + variable configdata puts stderr "punk::config::Apply partially implemented" set configname [string map {-config ""} $config] if {$configname in {startup running}} { - upvar ::punk::config::$configname applyconfig + set applyconfig [dict get $configdata $configname] if {[dict exists $applyconfig auto_noexec]} { set auto [dict get $applyconfig auto_noexec] @@ -315,67 +418,128 @@ tcl::namespace::eval punk::config { } return "apply done" } - Apply startup #todo - consider how to divide up settings, categories, 'devices', decks etc proc get_running_global {varname} { - variable running + variable configdata + set running [dict get $configdata 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 + variable configdata + set startup [dict get $configdata 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 + lappend PUNKARGS [list { + @id -id ::punk::config::get + @cmd -name punk::config::get -help\ + "Get configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + whichconfig -type string -choices {config startup-configuration running-configuration} + @values -min 0 -max -1 + globkey -type string -default * -optional 1 -multiple 1 + }] + proc get {args} { + set argd [punk::args::parse $args withid ::punk::config::get] + lassign [dict values $argd] leaders opts values received solos + set whichconfig [dict get $leaders whichconfig] + set globs [dict get $values globkey] ;#list + + variable configdata + switch -- $whichconfig { - config - startup - startup-config - startup-configuration { + config - startup-configuration { + #review 'config' ?? #show *startup* config - different behaviour may be confusing to those used to router startup and running configs - set configdata $startup + set configrecords [dict get $configdata startup] } - running - running-config - running-configuration { - set configdata $running + running-configuration { + set configrecords [dict get $configdata running] } default { error "Unknown config name '$whichconfig' - try startup or running" } } - if {$globfor eq "*"} { - return $configdata + if {"*" in $globs} { + return $configrecords } else { - set keys [dict keys $configdata [string tolower $globfor]] + set keys [list] + foreach g $globs { + lappend keys {*}[dict keys $configrecords [string tolower $g]] ;#review tolower? + } + set filtered [dict create] foreach k $keys { - dict set filtered $k [dict get $configdata $k] + dict set filtered $k [dict get $configrecords $k] } return $filtered } } + lappend PUNKARGS [list { + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ + "Get/set configuration values from a config" + @leaders -min 1 -max 1 + whichconfig -type string -choices {defaults startup-configuration running-configuration} + @values -min 0 -max 2 + key -type string -optional 1 + newvalue -optional 1 + }] 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::parse $args withid ::punk::config::configure] + lassign [dict values $argd] leaders opts values received solos + set whichconfig [dict get $argd leaders whichconfig] + variable configdata + if {"running" ni [dict keys $configdata]} { + init + Apply startup } - set argd [punk::args::get_dict $argdef $args] - return "unimplemented - $argd" + switch -- $whichconfig { + defaults { + set configrecords [dict get $configdata defaults] + } + startup-configuration { + set configrecords [dict get $configdata startup] + } + running-configuration { + set configrecords [dict get $configdata running] + } + } + if {![dict exists $received key]} { + return $configrecords + } + set key [dict get $values key] + if {![dict exists $received newvalue]} { + return [dict get $configrecords $key] + } + error "setting value not implemented" } - proc show {whichconfig {globfor *}} { + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::config::show + @cmd -name punk::config::get -help\ + "Display configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + }\ + {${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ + "@values -min 0 -max -1"\ + {${[punk::args::resolved_def -types values ::punk::config::get]}}\ + ] + proc show {args} { #todo - tables for console - set configdata [punk::config::get $whichconfig $globfor] - return [punk::lib::showdict $configdata] + set configrecords [punk::config::get {*}$args] + return [punk::lib::showdict $configrecords] } @@ -459,27 +623,35 @@ tcl::namespace::eval punk::config { ::tcl::namespace::eval punk::config { #todo - something better - 'previous' rather than reverting to startup proc channelcolors {{onoff {}}} { - variable running - variable startup + variable configdata + #variable running + #variable startup if {![string length $onoff]} { - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + return [list stdout [dict get $configdata running color_stdout] stderr [dict get $configdata 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] + dict set configdata running color_stdout [dict get $startup color_stdout] + dict set configdata running color_stderr [dict get $startup color_stderr] } else { - dict set running color_stdout "" - dict set running color_stderr "" + dict set configdata running color_stdout "" + dict set configdata running color_stderr "" } } - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + return [list stdout [dict get $configdata running color_stdout] stderr [dict get $configdata running color_stderr]] } + } +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::config +} + + package provide punk::config [tcl::namespace::eval punk::config { variable version set version 0.1 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index a3f5d95c..19d9d7e4 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -584,10 +584,10 @@ namespace eval punk::console { channel's response to a query placed on the output channel. Usually this means a write to stdout with a response on stdin. - This function uses a 'chan event' read handler function + This function uses a 'chan event' read handler function ::punk::console::internal::ansi_response_handler_regex to read the input channel character by character to ensure it - doesn't overconsume input. + doesn't overconsume input. It can run cooperatively with the punk::repl stdin reader or other readers if done carefully. @@ -609,7 +609,7 @@ namespace eval punk::console { "dict with keys prefix,response,payload,all" } -help\ "Return format" - + -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" -expected_ms -default 100 -type integer -help\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.tm index 26ed2f2e..8f1ba266 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.tm @@ -33,8 +33,7 @@ namespace eval punk::mod::cli { return $basehelp } proc getraw {appname} { - upvar ::punk::config::running running_config - set app_folders [dict get $running_config apps] + set app_folders [punk::config::configure running apps] #todo search each app folder set bases [::list] set versions [::list] @@ -86,8 +85,7 @@ namespace eval punk::mod::cli { } proc list {{glob *}} { - upvar ::punk::config::running running_config - set apps_folder [dict get $running_config apps] + set apps_folder [punk::config::configure running apps] if {[file exists $apps_folder]} { if {[file exists $apps_folder/$glob]} { #tailcall source $apps_folder/$glob/main.tcl diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index 4eb6526d..b89bc021 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -375,7 +375,9 @@ tcl::namespace::eval punk::ns { #This is because :x (or even just : ) can in theory be the name of a command and we may need to see it (although it is not a good idea) #and a namespace can exist with leading colon - but is even worse - as default Tcl commands will misreport e.g namespace current within namespace eval #The view is taken that a namespace with leading/trailing colons is so error-prone that even introspection is unreliable so we will rule that out. - # + # + #nsprefix is *somewhat* like 'namespace parent' execept that it is string based - ie no requirement for the namespaces to actually exist + # - this is an important usecase even if the handling of 'unwise' command names isn't so critical. proc nsprefix {{nspath ""}} { #normalize the common case of :::: set nspath [string map {:::: ::} $nspath] @@ -394,10 +396,12 @@ tcl::namespace::eval punk::ns { #namespace tail which handles :::cmd ::x:::y ::x:::/y etc in a specific manner for string processing #review - consider making -strict raise an error for unexpected sequences such as :::: or any situation with more than 2 colons together. + #This is only necessary in the context of requirement to browse namespaces with 'unwisely' named commands + #For most purposes 'namespace tail' is fine. proc nstail {nspath args} { #normalize the common case of :::: set nspath [string map {:::: ::} $nspath] - set mapped [string map {:: \u0FFF} $nspath] + set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] set defaults [list -strict 0] @@ -2018,7 +2022,7 @@ tcl::namespace::eval punk::ns { } proc arginfo {args} { lassign [dict values [punk::args::parse $args withid ::punk::ns::arginfo]] leaders opts values received - + set nscaller [uplevel 1 [list ::namespace current]] #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. if {![dict exists $received -scheme]} { @@ -2081,16 +2085,18 @@ tcl::namespace::eval punk::ns { } } else { #namespace as relative to current doesn't seem to exist - #Tcl would also attempt to resolve as global + #Tcl would also attempt to resolve as global - #set numvals [expr {[llength $queryargs]+1}] + #set numvals [expr {[llength $queryargs]+1}] ##puts "THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]] - return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] + if {$nscaller ne "::"} { + return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] + } + + set origin $querycommand + set resolved $querycommand - #set origin $querycommand - #set resolved $querycommand - } } } @@ -2098,7 +2104,7 @@ tcl::namespace::eval punk::ns { #check for a direct match first if {[info commands ::punk::args::id_exists] ne ""} { if {![llength $queryargs]} { - punk::args::update_definitions [list [namespace qualifiers $origin]] + punk::args::update_definitions [list [namespace qualifiers $origin]] if {[punk::args::id_exists $origin]} { return [uplevel 1 [list punk::args::usage {*}$opts $origin]] } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm index a64eef0f..7bf8306e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm @@ -175,13 +175,13 @@ tcl::namespace::eval punk::repl::codethread { set outstack [list] set errstack [list] - upvar ::punk::config::running running_config - if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { + set config_running [::punk::config::configure running] + if {[string length [dict get $config_running color_stdout_repl]] && [interp eval code punk::console::colour]} { lappend outstack [interp eval code [list ::shellfilter::stack add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] } lappend outstack [interp eval code [list ::shellfilter::stack add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] - if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { + if {[string length [dict get $config_running color_stderr_repl]] && [interp eval code punk::console::colour]} { lappend errstack [interp eval code [list ::shellfilter::stack add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] # #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm index 92b214d8..73ea752c 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm @@ -674,6 +674,9 @@ namespace eval shellfilter::chan { #todo - track when in sixel,iterm,kitty graphics data - can be very large method Trackcodes {chunk} { + #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) + #e.g [a+ reset reset] (0;0m vs 0;m) + #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" set buf $o_buffered$chunk set emit "" @@ -686,12 +689,29 @@ namespace eval shellfilter::chan { #process all pt/code pairs except for trailing pt foreach {pt code} [lrange $parts 0 end-1] { #puts "<==[ansistring VIEW -lf 1 $pt]==>" - if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - append emit $o_do_colour$pt$o_do_normal - #append emit $pt - } else { - append emit $pt + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$pt + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt + } } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # append emit $o_do_colour$pt$o_do_normal + # #append emit $pt + #} else { + # append emit $pt + #} set c1c2 [tcl::string::range $code 0 1] set leadernorm [tcl::string::range [tcl::string::map [list\ @@ -732,7 +752,7 @@ namespace eval shellfilter::chan { } - set trailing_pt [lindex $parts end] + set trailing_pt [lindex $parts end] if {[string first \x1b $trailing_pt] >= 0} { #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" #may not be plaintext after all @@ -740,15 +760,32 @@ namespace eval shellfilter::chan { #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" } else { #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] - if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { - append emit $o_do_colour$trailing_pt$o_do_normal - } else { - append emit $trailing_pt + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$trailing_pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$trailing_pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$trailing_pt + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt + } } + #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { + # append emit $o_do_colour$trailing_pt$o_do_normal + #} else { + # append emit $trailing_pt + #} #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext set o_buffered "" } - + } else { #REVIEW - this holding a buffer without emitting as we go is ugly. @@ -759,11 +796,14 @@ namespace eval shellfilter::chan { #puts "-->esc but no detect" #no complete ansi codes - but at least one esc is present - if {[string last \x1b $buf] == [string length $buf]-1} { - #only esc is last char in buf + if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { + #string index in first part of && clause to avoid some unneeded scans of whole string for this test + #we can't use 'string last' - as we need to know only esc is last char in buf #puts ">>trailing-esc<<" set o_buffered \x1b - set emit [string range $buf 0 end-1] + set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal + #set emit [string range $buf 0 end-1] + set buf "" } else { set emit_anyway 0 #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer @@ -774,15 +814,18 @@ namespace eval shellfilter::chan { if {$st_partial_len < 1001} { append o_buffered $chunk set emit "" + set buf "" } else { set emit_anyway 1 - } + set o_buffered "" + } } else { set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code #most opening sequences are 1,2 or 3 chars - review? set open_sequence_detected [punk::ansi::ta::detect_open $buf] if {$possible_code_len > 10 && !$open_sequence_detected} { set emit_anyway 1 + set o_buffered "" } else { #could be composite sequence with params - allow some reasonable max sequence length #todo - configurable max sequence length @@ -790,39 +833,74 @@ namespace eval shellfilter::chan { # - allow some headroom for redundant codes when the caller didn't merge. if {$possible_code_len < 101} { append o_buffered $chunk + set buf "" set emit "" } else { #allow a little more grace if we at least have an opening ansi sequence of any type.. if {$open_sequence_detected && $possible_code_len < 151} { append o_buffered $chunk + set buf "" set emit "" } else { set emit_anyway 1 + set o_buffered "" } } } } if {$emit_anyway} { - #looked ansi-like - but we've given enough length without detecting close.. + #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. + + #looked ansi-like - but we've given enough length without detecting close.. #treat as possible plain text with some esc or unrecognised ansi sequence - if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - set emit $o_do_colour$buf$o_do_normal - } else { - set emit $buf + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # set emit $o_do_colour$buf$o_do_normal + #} else { + # set emit $buf + #} } } - } + } } else { #no esc #puts stdout [a+ yellow]...[a] #test! - if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - set emit $o_do_colour$buf$o_do_normal - } else { - set emit $buf + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } } - #set emit $buf set o_buffered "" } return [dict create emit $emit stacksize [llength $o_codestack]] @@ -849,20 +927,29 @@ namespace eval shellfilter::chan { #puts stdout "" set emit [tcl::encoding::convertto $o_enc $o_buffered] set o_buffered "" - return $emit + return $emit return } method write {transform_handle bytes} { set instring [tcl::encoding::convertfrom $o_enc $bytes] set streaminfo [my Trackcodes $instring] set emit [dict get $streaminfo emit] - if {[dict get $streaminfo stacksize] == 0} { - #no ansi on the stack - we can wrap - #review - set outstring "$o_do_colour$emit$o_do_normal" - } else { - set outstring $emit - } + + #review - wrapping already done in Trackcodes + #if {[dict get $streaminfo stacksize] == 0} { + # #no ansi on the stack - we can wrap + # #review + # set outstring "$o_do_colour$emit$o_do_normal" + #} else { + #} + #if {[llength $o_codestack]} { + # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit + #} else { + # set outstring $emit + #} + + set outstring $emit + #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" return [tcl::encoding::convertto $o_enc $outstring] @@ -2260,7 +2347,7 @@ namespace eval shellfilter { # if {!$is_script} { set experiment 0 - if $experiment { + if {$experiment} { try { set results [exec {*}$commandlist] set exitinfo [list exitcode 0] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm index 35de5e704f3c9f66b7648340e6298f248a15f998..3ae60d426cf6b63988005e9d06eb1aac81a2c04f 100644 GIT binary patch delta 8502 zcmZWu1ymecwxt^h?oM!T+}#PDpuq_eT!TA}BtURdc!Ik-L4vzWu;5OD2X{V?mzjC< zr+cm2d+)RFsjhpg`a3osB80xyU#054cvKpY#hdKwml4;xXFR6R#j z4Tnxzo}ini6yQdU4Flt(2P`M^0Apl~P#cGNxr966dp!6bDD-HGR*YOh0R%nvyuXLw zK1Y#6k%++RVJevFm?%|oGpkj}j6s)g3fAVm_#Fi!YXfQ2VqJG#cNSy~j*aM=g#=Wo zR38Qcr9V!hsGCg$1!>C+w7sUC)DK=e#SL#Ta-~>NU%-^+O3m>=(GnH83phv`gwn*U zW6~^)#w9{p*#uK}@RVg^qe`W33F9RVmGJWpmd-$TA%P#*)U76HP9~UDvvFS-@yS%a zq9Q_gNU-vs`1$5J=Ba-7n3OM5-0uygE6JV~#2^h?_JVHQmRXLjHN)g!(J+0;sTp=5 zzd`utZ{7w!4S8{7>y{TQ&lAUPZlR4NfhnimJB`#16Q5lch_-Otrjsu`wcq{5fD*cU z`E9OcaBfv~X~-HI<*m*635Ybmbm8tWTtiGD(X@W=#H-G(CKNAQr>4F~INeIaHKm!w zQmBw>R+!nNtDvfq%U_Sj^o;;Nu)IuhP+!MBwc9TRt~yrlG7Ao0H8@Yb@GBG_!o7pl zal3M^N$YAwvR%qrCJ^A~dVbrcNS@T3vS-tH_KL;$_%`!$v=g4fzNmVP04Ij&1JW9j zZLG$qB###55+nx;U4x1pz6Xmu5X-fqSv3y2F@J;PMP)EDd8Epdd1w1jbWgy&t3_;I z5^7KgX3gE-{h-iO5um77=LB7>MJ`TE7_jP8`!Ut6OuhuYZqhbrzDmc~HrdpKZM*w@ zJA-j3mKJ`5?{|AGUm_>y19f+Fb-h1;jy^DIGTjn*V{BTOoc-E4zUyuM=-H~o}P{k`v>Tmv)@~=W%Kh-*I9079VK@=?9DKjhMNYQbSKVDp_$^1zUu>TUh8(h0jzH(k^8Au=i{&5#ib+4}OjGZ)i88Y6g9z<> zw~Wch)>j8qJjD?Nlh!rf%G!628l(0!Fev3j6KI*@X$aY$b-An4 zVggEcx6JbkDmCX5%IBNffqO8Trtjc@Z8sM4^CO44s>7|4%&6(9lFS1}pJg$cdw#-- zK(sKaB>i~9Rf zgumzH=vx$IaN?Vi=8r3wUptKUzT@Jj}^bUif@l`g8 z?doxrZLc0~{xA};P0_hGB5(gtU@g^2j7N5SodsF()PXZ*$a5-#t42UDwz5CMPipoS z{BUx4l+Dybr2i@(qO+350RAeJZh9&KA1SfpCyNziU3y1+(sisl9KR#7O19gX9zbZT zdX9TYSQ#FmAf|PRf70zhP>~5G_PMS?oM5bnbxdT9@yI_U&)plGGvW(X=n-b{eP=M; z@i5XahK!o_GxB+Q_3K)RRKM5K8qZpudD>?yA;k8ZLyVE_K-dN^f-1tYm&qibhmr_U zU~P&7{o(`R>?*;?6Dh{m%i<_{l2WcJa#Q2I?}K0+nQFWY$ydYFJ1VT-V+V)pO z;m|)2iFNkaY*b~Tn-eH*{1D=*b$)bjtHQ$2c1RnB-m>@uK}U-MPl@Ta=O|=Q9S>`} zL)8CJf~qGo7^_8F2^RSpdW8_=HFi9h;_J?Xh8he)v0YF+P7rs&IC)>F+qj8(%xm>j0wFk+# zMQMn?Zl0erY;~Hx-6D>mf+rJeKMnV!AYGq*%k(q91t(t!1fy`52hAm&;7A}RWaBC@ zQSRn`X|Z)WRgA=Jhw#be6j^o}%}hAcq1@=keBj&lAo&Bcpo1~E1S+}Zj!7cULoeEg z8MDFG6va-YlFG(A>EUzUx0`&FmUe`$zHc)t6kCVH91^$C=T{WK!2!k)a#%C-Lk}x7 zuNRr+cg`dBXdrGgh8|HJM9YypFM3wM_Tq-{7NUW5<@GII4%0zq_I)2EC+b;8Xzoa; zl#YDok}=BI7fi$P;9g15XcjN0KqE9GV(Yt=!R8SueT@-4#KDzo z-u}SJu~m*|5Ku_wPD!|p$WZ)itBe76)fkBn0U;7IBL{lc`OufgM$LUn5RUBL{nB*5 zE0?J|4@a}{(!-XiI&1FR3Rm_7x+4XDM-RsMcQT+}2bS0{nj|IA-TEkUHbuaq!tUL= zn2@Yh-xc14g>R)WNt|D+J<`33g(V$CKHe#jAHj0S1H3e+$_j^p(%ptur%5#HjGbtY z-^g}q@hUm1cQ@g)K6GYmS-F+S;ZeYQ1`7h9m~)W0!^D}4aLl~0mr>SAw%rGIE$I$ zvwrJEOy{I5nXG(baW*0YqSR_Y5n|grMp4ddtpJHS#9CVl`yHjN^PH zxUD>qfc#<0JYyI2ttbZLP)R2%!}zAsN4~^Fhx>l6Af#Rso;rdh=(now@(&?Foug7s zfxk!BiJ+?m;S$c;AdhUl_oY7Z9g&x%gx;7TFXY;Zsq7Wf7S#L&@R-`GAqzFgYPX~3 zr|QAQh~eoOGaddc*ZV`}Y1^HM!SeWwam&^(%YWiD0crl7cWNWs}3GC7q8IR+)*5=y&YsYxH;AB?xkJ>x~=5dtem+n>PTws4?0_vNmQGsByf#` zX~9svPPts{5LB}O==8GRjL2+KtD)B0`9*us43k zRnKn{(HKsj=R6_9*&Y`go|uyn>bh5*mV|0CF3y;Ch*q_>hvUqnWcFVSa96EH2eGZ8 zWO0=G&iAASclg_-aW9-k=i`084J+hs8nvg;R;7LDK#|XmGXd3gaioV|_F8JosXk|- zqUkaDhD)(qi2b#H6z)rEm9yhnL{|*UUZPO~ zV`kxFPm^Zx6}Um_{NGEUQx%e5r|B}XS5G9FYad(DvE7Vrd zmAKhw0F^-ihRn~sJG=PbdrH6Wq)<^r^1Uz|)-X)x^1W+EPv9A`CGb9DNZPVUV4-Re zUW&W0OB8li(UzfgW>>nJB0*$bhaSO}tlH$foz)~PkzYBOY|aj{M|IN8=%u|7j$k{U zEf>l_5R}sF+pt(8Vk(p|#(8Cq|jf8+rMl8l>-9ut?fm)**6;wBlihk+qkGN^c8=t3RglN z3iw+r@2PqGDd~OFfg8q34!(=Dd&1<~m-;k5;ub6fCm~o{p%FfTyme( z2a87O-8%uX=RxOWv_0qj=LIn#1~*O?Z_^9wH>4o9oc6@=>R*+F^#{Gh$_R`z}5U}J5T)qBJRZ)IQWf1~2hw63 zl3Zc)O)Ms5BI;FQ^tubDkUra0$nz_kudr@n130orhNt`~;jUlhZTDE5-YjaoCLnO{ zn(UDhC}thW;$TK9L1R-;pM*VBX8x2)gk4o-c*Kn6qmJGe0=4oF1{+>q4R7K#BT>V^ zeIsO2ros}ZUYG6{iZH=1$MF4ef9piHl*Ol{IyPnJJWgIWo%w1ubew01rH5F0W-HA_ zrzg6?zv1VE(Hw16MY2*`Cez3F`%_e37koI-_5%q7f1}AoY@qruJ8IZlZU&XI5y-9p(?`isZF zC}8x~6dKcH-^q^p!W{~~x+k%pQ=Z8%=D;u}F)cnXO(UJ48yf{}O)%|Z5ZuvUjY(v# z4B#ukdl(`_x(@A(fA4Bg*~R;UCMZRcW>JWnC>J5ys9GgcQfXBTQ#R;It{pN}V%)!f+C!`8~)=HcNfAwcRw21s&n01m?# z$WM-khsQ%#hxjxz6a8!7Ornx>UkpF{eFqN%!^Q&xBLR#@azg)3&i0Q(?&~c(tjS>d zi7`HOB6?UB!@(P}Vra+}da1fL?i{$t<|@EtcE3T#sdoFe3-|uE)!qCKcAikk3g?sJ zehA#*(8$Qh(1oY1ly_h5Cw6CF_QlOlD6VT)`c4ni_{)?>%z5>~Ue2dIZ?|}EM%tm< zd;$B;DtSTJFR0oR^s~Oewwj@z-q3_1@X9*CM3)9PpXwXNzT$3OexOxrFl!mkL!Z<3 zT+mq9ktlwR85>e27coKEAQ^4CQlKG3lb97f|8!xWO z#a7_(0@h5ZYFYN>rnQ+-#~hXoQ$Yo^{^Lv#&MDPV22PVZr)#O}w7lS4+D5=;8nb~UkwH-MwZYa#qe%>!h z=oVm{7I_p3-hvZ^eAP4~XXIw~;YiUB;VAg#PLkVWW)+za1O(qP89IJ3W>g#V?yMir zX_jpt=^ZGQU3ocK>_TR=qnPxIvC@cWiu{Yji;(u(@uOJy7rqwEZ+-bZld+{lX_{QP zVsBqexGB~Qe<#rqr_MqXev4WMh1-%NF!{8qNjB&x!&R7ib>JjvQK8cgBNeLnJ+H&j zFAop8G}0wmVS8GP6KzVDBbb9Z^|Cculf9Cwrsh`}`=0f_Z6=FHm+-VXE zl+Q{u+$b!h({G4pr!_~@+UYD1`Kg$aiSR)N{xjRrdX9(-vER%kcaQHvRyS|@X9gXh zcLHC0u7$tcp4&NHT_g@JJMynsT~u2%bw$5Z34~-`k^X)v!0HUH#N!X2aFU$}dgS z_|E$NAhH3~j8I-mqRkP$78We`0P4$8RF4>T=qx7}y~C2Kq`f4S*0cTafc8rUu^a5| zcbZ_rC#u`vRF6$m(1kcSJQm8wIi)5R6!r^(vsP>(QCo%OZM~F12;~RM#KQ8Au4}8% zj|s8ppEkot(8qWClB+TQO!@is+{UfSvOvXIy4(8q`7Xg=&#z_H1iE6kTImxIlL(jM z;W77#Z`}c2zsEq1U0?!M^9FIM;F7N#4kzJRROIh!OiPjE7pdm4qo~xkm53}+RRNCn z9=WUWK`zh~0XoIWYUo*{O2C`Cz)+Lp$i?s2uk;KPt$x_`&ItABu{XAI|9pe0moOZ@ zne*N8YH{)*VpbRL<#Zae;m0sW!j5_b$P~Mr;|Gl*9;JEq{eUFR6$?}?PZ9#8x1W6X zTI@_C4Bu^QD#VFdpYUcKlv2hAYoNR7Su%Oa*GMspv$GSy4x~cu^lJB=8)eN>hE2wV zTF3}jQ8rT!&X`t{X~uqfcXFeB7l!}-^V!Tmt-jLXIT<@8-s=w9*Lyk3^s^?)hd6qX zE@?UNRBi9sE@dj4JXlCEWm29y2xbH)qMu!>;h^$x!RyK|Nnz)UOLIi`L8y6U0%?l7 zXJW_l5^e1C-3F$hq}$-pX?FHd)fqM*NZZ{&M!bBJQC+?aLXK>9tX-Hm=$K2lDaPs_ zOh{rP{G3B3`r@!VN_CybAc%#z#Y?G3`gWW;ZOWf)p*$98K0w9ZXv8%#8ocUEufTG} zF|Dw@y>0BaqbK5puy1ioCo2*?aWSt@aJsj*H}%dcF4h`)|9ny;l?`7a*GWELl5nP5 z-R|VgyoX*BwmC0LfA9|yb208}*+aC08Q4K1;@b8D=FuzVo-^v{RFmC!W}hPX9`tg8 zNiW@Z2#ghomWM}dHSJFDsjWuW=?T7H%Nk(zYBstD3OFpEzaMjFs_dco{ZRMHh86$N zntS4!u5?S6cS2t=ZKKk@gfGG`8fObSVCopcly=8~)Bo`AqJ{|bu_j4($!qPh>anPZ zBE!Il0hu2GK`Zf}%&=)77kwziC@$c1jckjBJmJS!GW85)2nxJew39>k8xE&F-` z7sMAQh1-BJERBa?G~XV$X+~LFZ8a?m9e@3{D)ZC$d+MAQX#`mYzfvUa79pKH8a&)5 zwa$BQp2H6C`gDLaplHpRrNb zo}Y$|D0!>ivH514fw9Uxzu0x3IN$6emCc!5;aFt?!fH-`xO(>_BrL*Q|HZh!2eiPv z{-)FGAY3+uw0b?_G8=gmk_$EIB|%>bblPO|dhc@cvhQGZH@eR+B$O}hRC(cK<$BHU z+C|9s91cOynAm6qDU^&%=%?`nc5~FfPpB z{oUi!LqN6gE82fOJOuEHqQEZ+fYmAvV7kZ^y!RKB24aiZK$1XvaX1*3>`_nzRs_(1 zyb=f~0~jxf0LxK6iR@(HSHsF4WS5)(Xjd}h+G@wiw2{@`l1vG2Oz;3)xa(fLIn4a$m_Sa%P-45ScRKTp844n0s^a2>@HUr53>^+5`wZ~B$IB*kqvKaP~f&B~~En+}R zuNep*80(V-ls!-Yw>}+E<0GpCzcG9YTYHK<%|II<17H6w*$!BMQ;eRXBi;x=i5JV0 zW77*4^*@UUG5%vf2E@HNo(xxmWZ;f}$?|_m6#vuS|0lsCvN!qbY)SsncK`oQAIRt- z0ZNC+z^5ia<)}D-Hp~W2v3!IQ0CZRw3~T!bA^^T_C;-L?1RU+~B>9Z+gD)JPV3<1w z5H^AeV2_f4Ke{|ha!)JqVH5)D0xCuWz`wnL$}t(hKOPnMFa`mq_&-u_uyg3sY=?0k z@O;=GhyWORBRwT^&BI3j=edYR{@ZfzjmiAazmosC<@o137`&Lr3xh-SfA2v4nc{y+ i&wr(GO!zAW-T$vdDvIz3fBBRj-x&}XnBb(p*#7|@cE9id delta 6274 zcmZXYbyyW$+qc<6$7TZpg2HA?vq4(vl15TMLOP{EK$Gp52%@w|m!c?L z((rO~`|v&A`_3H49M^gNu359z95er{$VT*-T=a@)^r~2Nd2)3A>V&E}$|?-#AmM9W zZcVdn4iYr9JTM(@h&pwc;jg{$*wZ3XW*;Rqaa-SHCvU*n+_0-^>e=88;0>6PHle8Q zp0uVPVO4n99DI4`1%EfcLuWTlIa~kSMt%97$I*@u?1^Bq{FbtEyxe%(dxRS8L8nH_ z{vskVmfKMi_d!w?zetY>yEZk>5h)+Wh$0iqd}o4+3My0R2Z|f_J3j{QA#FJ5KC7@hzN1OSbOy0)Z z*cc*OT>GjEc;>aDLUIXV%VxCGW*K^!j$Dvz}CvSMhH@O)CFkjh_|8Mh2>pCo-M_7e%#g24^z*R5ot*rR_6Py9GCN4hrsx!tmKImSEqMhsyP+GW3B07#`>Tq+W6uzx4Ip}bX?K6PU0Qwl3Y?u z&G3L{m7QM3v`4=ic|Rxon$TI#m*>3O5XPZkL}LD2Fu@aLll3SEe(w{^-a+$8QmvYU ztCJGuiRQ+!Uy^8MOX|8!sBr!Faz1QJ>|DR3Z2oL0#JTcC6=d+!|6h3;m%*S<_g7vPneSZ?9ukBvbomINzFStIIJfD?3&v2ooQ=d{M<>{^eP~CL zy^k2el-uzNv;%cd#4jWW)(S>x_jaBxJJ6l`Z{MH#DJ{M?M0%N)d(=x&4$+>ko=89M zLq!>#_A3V4A&XppozaNBZ41(z6=`d3uAhDB7NWXtWf+z-rhc+R?z>(v+*t99GH?~c zs!5>)Ww<(1GfH+VJ^b4X$qx-)OwrUrohKJ78(%n*e)<=z?VimY8~QoSQ@ho=zS2ny z#NH_#4B3bKj`Mm}#GZUrsx=hr+d6eRz3?{pxqZ$sq0{tf99HE*CNJ%Q%QKT#Qbogx zt}$*$lv6$=ypHZE{Du+<>yyBCdt<%cS9&B6iRuuz9Tc&@vmD;+Z*6&B!LZ$slH>U6 zW4+F>RF)L4LzzB|ET{%#2~w}4#|BEVE7jtpXqb9&TKCDv7WVmwz(EtC?(2=$#9 zMoG|~rMVv|o(#RaY+^ijkV}K@VcwpsK@j(xvLGL)0H%?Mra*1ElcxV`=qvPaOlLo_)^N`CRH^Sh z*|tPrJ&P1s5t5-Y$s8Giw)S}M%rMv%U~RRs`McmPiO=TZ)6Y+x%2J-be=rHnj^l#K z&^$`2*+zZ)PJ@Z%wl5PsG*vupgi>xp(iWjF1PIruF$VOR@g#5t)uM%!WlL)Jj2wm# zF)jBJ%1L<)8J(~jnWW(&SWFA!4xgK_l+)3Bhgq2U4>!EGA~p6imyAP@t21;EY(%{0 zz?kxJ2y<*SO`ZeQHs%gAejE4mOt;cbTRUwz3eDoER#|z3)2h2ay`DH9w{NqFBRJr@Q?8Mx6mR?%%c{mk>0wQ8N?ReJAa#?1&Rwt zk0RP-J#Fl55xH*uan8=$5mw^zVhcu3V7k6Kds}6BejU647vA!x)Nq=} za4kbV>v!1e)*-8yM>LFgdA`0PWpO;k9q0Jr=MrgJSDN|uMET7o1{(80TEP-j)E&6p_6$)mv8EyTlD z)}luUN%6S0b-_+Eao5&KwQoC9_scCiy*xXG6l=9TFMgs4;qNwukP~4*1uGnKV z_;H%)K2DH?Eo3>U8NjTC&QD;_eL!p#AbEgxkZVg5U>JnV){aRc!Cmgbi69b?3eGa1 zs2rzsV!msoEwm0vy|s*D)!o+aJFS#fQ6?&Z6l6`nT4&dUyAQ;D`9p$!PPu)Dua)<0 z#cUIlIe=_(P&>GDHi;ue(O_f!L|4^&Bvj*=U4grRbDQ(m^pubMMztKgSU8M zN*eXNJR2I+xr681bFO2^HiVVCQ2s1VY@BjbYDG17mLUd0&XXZt{W2cEZ=`Vf-|=Gf+0UHnMMs;D zUVxk}bq}sVok)XG5(6)ui-Ho|%jGNddD1QiMg)>go<;n8*ys}P=i+3B6j>HIc-+r$tJc)|wdLK4dfg7Ri8Y_m0N8{NuSE&s zu&pa<4;G2%&}20Cg&x;v9RrsRK}zC6n3;#4PiQlWx`4%^Y+6<8wSBOn0tVdvoCH#f z*}6qFxV^;iZD~F_;>-6dbB^>7d*@h1*kmM?#KSPJXV7}gWP=5xiuf{V;C{LDk-Uu@ zPDm&QE5+*-i?IyMVaNJxg}E4IA6vVtiO08GXR+>nnZNXFWsOQu}v zPjFc!b{_u=h3s5rTCL$+jPMnzOF8hS=-}+93)+1aHP3Sa%md%CSJ6{-UKjcIq>u5Z zv3CT-X6d^GLgr-D+2lQNMZ9Q=fsB1Rf`U=i&ToL6)s&OPYC z9m(czK6-iAue4!{5nha+@5FGFz7noixxkyns}vZhYedJFv#<(ia;y}>v2xjtMf z+)XZja+wWRTplP6e{;uRGjaaM_I#wtbF;kZ<&YwV8YeLeeKUm*N(^#AN0ur1M&We% z3y2Z@Xx>>W8Ds*#88iM_)y1Et&5jRe=fQVoHecTA>tL3BOGKLYTXe&>j@jHfKls!y z>4j0lH&oKrl!=wW*oL_S)?NCX4fv=i2r!MHh6QcKT>><=w;#HHbVjUCJ~&+%jhMCT87C9VUt`>tPCW~J|2aZXCf*U2N}Y@pmklo?PWJS$4Q#}& z>Egr@)Uf$%A=%IH*2C}Nc!B_pnEZ^pMSGKS30$a@b&a? zCp(9g*_|kQB!vXvg>S3FAofO`gzUPBA4!zxqj1Z*?KNq&)p+6NYcw+t5Fmc~3Pot_}5h#!(LYI@B|SWXkH1apF|lK3X`}+H z$6LMz*b}@!X34T0&bD(5wi>#%ySN0SY`a+=_W0;<=Xb)DJE#}6=?az56Z*Q-CP>1L zY>kzCdD3g&-!Bb`N`GN%go#C}$EU*N9_mnBZQ~}DK0u|&R~`P=Vjw=~S$UQ@r$Oz; z^e+s2N?1$2iyvXUkWq}9_Xf*j)^CA7!r##0?lFzvq}K{3;_DYPJdN-T?ajXjLH+(p zHPc1jQli~+(>=gnW?Jv}{7|-rY{t?#h~BT7pf|Ni|{WXkrTUXvB}A zw_=k_7S^H(s!hdDoq4PhMmTLxUTJ`5R9)r2GMno56hw;VW20474ATO4wNE$~=$P97 z(4zLjoILP_d0q^4#=}={74OChmNA(crs_z#)= zWbY273wv&k*Mci~s4F0LU1eH5AyowySGP~cmL@pIp8E-`hr{_$kmP<`^~@v%Jn zm%TbLXI)PF`ma*D`C~l8fzv|9baKgyfiA6CSQ{b=ksIKK+C5m)pOtq3ANWzKaXE1B zaOL~kpPmuxN$@7Wunmpu!2Zg~7`Qu`6gDvIx@N-g%7+z!wpWdPFotPqaaa&Qp`d)34Z&ivc3)ojA-+kzygbADdrXm?!r>nJ`@X zO)5H)3MbKGQkLl}+wI6IYHgH)_SQ#_yEL{TgiC+4^7kZiKggJI#@0bfDAw?IBXH?b zW>XCEoyQ6tijPW^)-UnKodO{v4ka9?3QlKb_wHt+y#?zN^OKY$yx;@anLJUv@EdBe&N{0G(e z2CLnC2(CDu(8_MLhOC6U?0T!^Gi#E8BeND5uXpQ4#X_gEiwPxACNWaXouq%f}Y?Zx;w}+!G^W{pc>|_>&AC`Wk=F%j@Pu#8bTiwQE9*n~B zso`9oE}?9>{GC_zYp9V0)-S?jmh>tI)^Ahw%I?XmSM%zUQAfaQ)Nv)-ENhPG1N7LQ z&4X5D?D*Bk``JDTzxee8&2_%h(rWSX8GV~rE+`sany|xW>Q0Zl{~bn?%>h8Sa4h5p z4aIL2a0ODi#u=0KpF#sZEl+U8C28KBQ<6Q)5fBcKvA9=8WK$Jiz}I8YlvhWKo@ibK z{zygKGI`bvB@sqVD&6xjF$`W_S9CeGt2Onqex9@RoJXu2*MAk-NIaW;{@DqFFBv8vw`M~h<>B^MVrvGI!pU9)2$ z(h)Q?GRBBJMvvEs%nJY;yQuh(Ph~OLix7-1p zth(h{Bu{OIe#SMN5L0_fjs>ssw?8d#Hc)8V?anT4e#+u94qdqOW8rMzsryjR7A2-5 zLGi0ki4w)FGacrPjD2gz2uE2HWp)>5VUyKLNnM+Qd(v73qT zIray>@k(bJAp{yH3&8!0bR!bQmTLe(=`qYV1tW~U|?M%5~yMRFGX=ZH7qF-=+&}s4t~(7 z$sed;y=fG0<^!yFZ!lQ}3VO5=flJMI0J{e_TCPPL@PBxNrK-5#doU_62I}{40GT_u9xsm*OrVE_s2Jq0Dk_`uQuDWhZ3kYfdEipmV z3p{Y(6B5|{SFwNA2RwDI(*|csaPBh_z<73rqM(8+BWO2>1cLuTG4Qji#1#^N3`1}L zsdudkhls%wcT(_T5DP3H5(Rqy)$GHjfQkOU9d1G(bOZ^U{EO}*Hb92Kb+Y0vdp(@n zC>-(#6d#iYqdf$#&A0~%SX@N_nZL66fUnVYJM*|cKxlkjZg}B=!{g6@y#Jv5^=--% zaNvo_RR=eiIUxd^SYDT}zmkFTSF`5+iUdq;{wf7v%l>Z(1F0wZ0WGH+EOdi`tdj&_ z)g&DF<$R;vM@YbesjG3O;1GIHZORW&^STM)iNqk|^wla+H%i`<2+X-sV<9(+XyySR v6n=x5*;wG#IPUesa%SK_M&$n&QF{}St3JlW`sV{vygK<<(9m3C{-OT?q*SmI diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm index 8c778061..9f4e75ee 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -4301,7 +4301,7 @@ tcl::namespace::eval textblock { if {[dict get $opts -frame]} { #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table [a]" [$t print]] } else { set output [$t print] } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.6.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.6.tm index a562545a..7abbaeae 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.6.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.6.tm @@ -265,7 +265,7 @@ namespace eval tomlish { #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey #DDDD switch -exact -- [lindex $sub 0] { - STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - TABLE - ARRAY - ITABLE { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - TIME-TZ - TABLE - ARRAY - ITABLE { lappend values $sub lappend value_posns $posn } @@ -311,18 +311,16 @@ namespace eval tomlish { lassign [lindex $values 0] type_d1 value_d1 lassign [lindex $values 1] type_d2 value_d2 #DDDD - if {$type_d1 ne "DATE-LOCAL" || $type_d2 ni {DATETIME TIME-LOCAL}} { + if {$type_d1 ne "DATE-LOCAL" || $type_d2 ni {TIME-TZ TIME-LOCAL}} { #we reuse DATETIME tag for standalone time with tz offset (or zZ) error "tomlish KEY in 2 parts does not appear to be datetime '$keyval_element'" } if {$type_d2 eq "TIME-LOCAL"} { set type DATETIME-LOCAL - } else { - #extra check that 2nd part is actually a time - if {![tomlish::utils::is_timepart $value_d2]} { - error "tomlish KEY in 2 parts does not appear to be datetime. (part 2 not a time value) '$keyval_element'" - } + } elseif {$type_d2 eq "TIME-TZ"} { set type DATETIME + } else { + error "tomlish KEY in 2 parts does not appear to be datetime. (part 2 not a time value) '$keyval_element'" } set value "${value_d1}T${value_d2}" } @@ -332,6 +330,10 @@ namespace eval tomlish { } set sub_tablenames_info [dict create] switch -exact -- $type { + TIME-TZ { + #This is only valid in tomlish following a DATE-LOCAL + error "tomlish type TIME-TZ was not preceeded by DATE-LOCAL in keyval '$keyval_element'" + } INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL { #DDDD #simple (non-container, no-substitution) datatype @@ -383,8 +385,8 @@ namespace eval tomlish { } - proc to_dict {tomlish} { - tomlish::dict::from_tomlish $tomlish + proc to_dict {tomlish {returnextra 0}} { + tomlish::dict::from_tomlish $tomlish $returnextra } @@ -437,7 +439,8 @@ namespace eval tomlish { #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW # #TODO - set tomlpart "x=\"\"\"\\\n" + #set tomlpart "x=\"\"\"\\\n" ;#no need for continuation + set tomlpart "x=\"\"\"\n" append tomlpart [tomlish::utils::rawstring_to_MultiBstring_with_escaped_controls $val] append tomlpart "\"\"\"" set tomlish [tomlish::from_toml $tomlpart] @@ -519,6 +522,10 @@ namespace eval tomlish { lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} } else { if {$vinfo ne ""} { + if {![tomlish::utils::string_is_dict $vinfo]} { + #e.g tomlish::dict::from_tomlish was called with return_extra 1 + return -code error -errorcode {TOMLISH SYNTAX INVALIDDICT} "tomlish::_from_dictval Supplied dict is not a valid format for converting to tomlish" ;#review + } #set result [list DOTTEDKEY [list [list KEY $k]] = ] #set records [list ITABLE] @@ -645,6 +652,10 @@ namespace eval tomlish { } } else { if {$vinfo ne ""} { + if {![tomlish::utils::string_is_dict $vinfo]} { + #e.g tomlish::dict::from_tomlish was called with return_extra 1 + return -code error -errorcode {TOMLISH SYNTAX INVALIDDICT} "tomlish::_from_dictval Supplied dict is not a valid format for converting to tomlish" ;#review + } set lastidx [expr {[dict size $vinfo] -1}] set dictidx 0 set sub [list] @@ -1522,30 +1533,28 @@ namespace eval tomlish { #DDDD if {[::tomlish::utils::is_float $tok]} { set tag FLOAT - } elseif {[::tomlish::utils::is_localtime $tok]} { + } elseif {[::tomlish::utils::is_time-local $tok]} { set tag TIME-LOCAL } elseif {[::tomlish::utils::is_timepart $tok]} { - #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a previous localdate - set tag DATETIME ;#?? review standalone time with tz - no specific tag - only allowed as followup value from DATETIME-LOCAL - } elseif {[::tomlish::utils::is_datepart $tok]} { + ###################################### + #Note we must allow lone timepart here (not just is_time-local which doesn't allow tz offsets) in case it followed a previous localdate + #set tag DATETIME ;#PLACEHOLDER tag - review standalone time with tz - no specific tag - only allowed as followup value from DATE-LOCAL + set tag TIME-TZ + #This will become a DATETIME or a DATETIME-LOCAL (or will error) + ###################################### + } elseif {[::tomlish::utils::is_date-local $tok]} { set tag DATE-LOCAL - } elseif {[::tomlish::utils::is_datetime $tok]} { + } elseif {[::tomlish::utils::is_date_or_time_or_datetime $tok]} { #not just a date or just a time #could be either local or have tz offset #DDDD JJJ set norm [string map {" " T} $tok];#prob unneeded - we won't get here if there was a space - would arrive as 2 separate tokens review. lassign [split $norm T] dp tp - if {[::tomlish::utils::is_localtime $tp]} { + if {[::tomlish::utils::is_time-local $tp]} { set tag DATETIME-LOCAL } else { set tag DATETIME } - } elseif {[::tomlish::utils::is_datetime X$tok] || [::tomlish::utils::is_timepart X$tok]} { - # obsolete - #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a previous localdate - #e.g x= 2025-01-01 02:34Z - #The dict::from_tomlish validation will catch an invalid standaline timepart, or combine with leading date if applicable. - set tag DATETIME } else { error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" } @@ -1662,6 +1671,433 @@ namespace eval tomlish { } + #return TOMLISH { value} from new and existing typeval dicts of form {type value value} but + # some such as MULTISTRING can be of form { ...} + # + #Don't validate here - validate in tomlish::dict::path::setleaf + proc _update_tomlish_typeval_convert_to_new_from_existing {new existing} { + #we deliberately don't support container types that can contain comments e.g ARRAY, ITABLE, DOTTEDKEY + #This is also not for higher level constructs such as TABLE, TABLEARRAY + if {!([tomlish::dict::is_typeval $target] && [tomlish::dict_is_typveval $source])} { + error "_update_tomlish_typeval_convert_to: target and source must be of form {type value are contained in the table + foreach tr $tablechildren { + set tr_type [lindex $tr 0] + switch -- $tr_type { + NEWLINE - WS - COMMENT { + lappend updated_tablechildren $tr + } + DOTTEDKEY { + #review + #UUU + set dktomlish [list TOMLISH $tr] + set dkdict [::tomlish::to_dict $dktomlish] + set newdktomlish [update_tomlish_from_dict $dktomlish $subd] + set newrecords [lrange $newdktomlish 1 end];#strip TOMLISH + lappend updated_tablechildren {*}$newrecords + } + default { + error "update_tomlish_from_dict: unexpected table record type $tr_type" + } + } + } + + #todo - add leaves from subd that weren't in the tablechildren list + #ordering? + + lappend output_tomlish [list {*}[lrange $tomlish_record 0 1] {*}$updated_tablechildren] + } + DOTTEDKEY { + #We don't have to check toml table rules regarding created/defined here as dict::from_tomlish has already ensured correctness + #UUU + set dkinfo [tomlish::get_dottedkey_info $tomlish_record] ;#e.g keys {j { k} l} keys_raw {j {' k'} l} + set keys [dict get $dkinfo keys] + set dk_refpath [lmap k $keys {string cat @@ $k}] + + set kvinfo [tomlish::_get_keyval_value $tomlish_record] + set existing_typeval [dict get $kvinfo result] + if {[tomlish::dict::is_typeval $existing_typeval] && [dict get $existing_typeval type] ne "ARRAY"} { + #leaf in supplied tomlish - source dict must also be leaf (invalid to rewrite a branch) + #e.g + #DOTTEDKEY {{KEY j} DOTSEP {SQKEY { k}} DOTSEP {KEY l}} = {INT 0} {WS { }} {COMMENT comment} {NEWLINE lf} + #existing_typeval: {type INT value 0} + #e.g + #DOTTEDKEY {{KEY j} DOTSEP {SQKEY { k}} DOTSEP {KEY l}} = {MULTISTRING {WS { }} {STRINGPART x} {WS { }}} {WS { }} {COMMENT comment} {NEWLINE lf} + #existing_typeval: {type MULTISTRING value { x }} + + #see if source dict has a simple typeval to set + set new_typeval [tomlish::dict::path::get $d $dk_refpath] + if {![tomlish::dict::is_typeval $new_typeval]} { + error "update_tomlish_from_dict - update dictionary has non-leaf data at path $dk_refpath - cannot set" + } + #update if type matches. Todo - flag -allowtypechange ? + set e_type [dict get $existing_typeval type] + set n_type [dict get $new_typeval type] + if {$e_type ne $n_type} { + error "update_tomlish_from_dict - cannot change type $e_type to $n_type at path $dk_refpath" + } + #-start 3 to begin search after = + set valindex [lsearch -start 3 -index 0 $tomlish_record $e_type] + if {$valindex == -1} { + error "update_tomlish_from_dict - unexpected error - failed to find $e_type in record $tomlish_record" + } + set rawval [dict get $new_typeval value] + switch -- $e_type { + MULTISTRING { + #UUU + set newval [tomlish::utils::rawstring_to_MultiBstring_with_escaped_controls $rawval] + set toml "" + append toml "x=\"\"\"" \n + append toml "$newval\"\"\"" \n + set tomlish [lrange [tomlish::from_toml $toml] 1 end] ;#remove TOMLISH keyword + #assert tomlish is a list with a single element + #e.g {DOTTEDKEY {{KEY x}} = {MULTISTRING {NEWLINE lf} {STRINGPART aaa}} {NEWLINE lf}} + set dklist [lindex $tomlish 0] + set msrecord [lindex $dklist 3] + #e.g + #MULTISTRING {NEWLINE lf} {STRINGPART aaa} + + #error "update_tomlish_from_dict MULTISTRING update unimplemented. Todo" + lset tomlish_record $valindex $msrecord + } + MULTILITERAL { + set toml "" + append toml "x='''" \n + append toml "$rawval'''" \n + set tomlish [lrange [tomlish::from_toml $toml] 1 end] ;#remove TOMLISH keyword + set dklist [lindex $tomlish 0] + set msrecord [lindex $dklist 3] + lset tomlish_record $valindex $msrecord + } + default { + switch -- $e_type { + STRING { + #review + set newval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $rawval] + } + default { + set newval $rawval + } + } + lset tomlish_record $valindex [list $e_type $newval] + } + } + + } elseif {[tomlish::dict::is_typeval $existing_typeval] && [dict get $existing_typeval type] eq "ARRAY"} { + #e.g + #DOTTEDKEY {{KEY a}} = {ARRAY {INT 1} SEP {INT 2} SEP {INT 3}} + #DOTTEDKEY {{KEY a} {WS { }}} = {WS { }} {ARRAY {INT 1} {WS { }} SEP {INT 2} {WS { }} SEP {INT 3}} {WS { }} + #existing_typeval: {type ARRAY value {{type INT value 1} {type INT value 2} {type INT value 3}}} + + #= is always at index 2 (any preceding whitespace is attached to keylist) + set valindex [lsearch -start 3 -index 0 $tomlish_record ARRAY] + if {$valindex == -1} { + error "update_tomlish_from_dict - unexpected error - failed to find ARRAY in record $tomlish_record" + } + + set existing_arraytomlish [lindex $tomlish_record $valindex] + puts "update_tomlish_from_dict: existing_arraytomlish: $existing_arraytomlish" + set subd [tomlish::dict::path::get $d $dk_refpath] + #set existing_items [tomlish::dict::from_tomlish $tomlish_record] ;#utilise fragment processing of dict::from_tomlish - to produce a LIST + #we expect the subdict structure to be something like: + # {type ARRAY value {{type INT value 1} {type INT value 2}}} + # or with untagged subdicts (ITABLE in tomlish) + # {type ARRAY value {{x {type INT value 1}} {type INT value 2}}} + + + #we can only have one ARRAY record - so we can use lset + set newsubrecord_itable [update_tomlish_from_dict [list $existing_arraytomlish] $subd] + lset tomlish_record $valindex [lindex $newsubrecord_itable 0] ;#passed in a single element tomlish list - expect only one back + + } elseif {[tomlish::dict::is_typeval_dict $existing_typeval]} { + #Not actually a {type value } structure. + #sub dict (ITABLE) + #e.g + #DOTTEDKEY {{KEY j} DOTSEP {SQKEY { k}} DOTSEP {KEY l}} = {ITABLE {DOTTEDKEY {{KEY q}} = {INT 1}}} {WS { }} {COMMENT comment} {NEWLINE lf} + #DOTTEDKEY {{KEY x} {WS { }}} = {WS { }} {ITABLE {WS { }} {DOTTEDKEY {{KEY j}} = {INT 1} {WS { }} SEP} {WS { }} {DOTTEDKEY {{KEY k} {WS { }}} = {WS { }} {INT 333}}} {WS { }} {COMMENT {test }} + #existingvaldata: {q {type INT value 1}} + set subd [tomlish::dict::path::get $d $dk_refpath] + #= is always at index 2 (any preceding whitespace is attached to keylist) + set valindex [lsearch -start 3 -index 0 $tomlish_record ITABLE] + if {$valindex == -1} { + error "update_tomlish_from_dict - unexpected error - failed to find ITABLE in record $tomlish_record" + } + #we can only have one ITABLE record - so we can use lset + + set itablerecord [lindex $tomlish_record $valindex] + puts "update_tomlish_from_dict: existing_itabletomlish: $itablerecord" + set newsubrecord_itable [update_tomlish_from_dict [list $itablerecord] $subd] + lset tomlish_record $valindex [lindex $newsubrecord_itable 0] + } else { + #unreachable? - dict::from_tomlish didn't object. + error "update_tomlish_from_dict: Unexpected data in DOTTEDKEY record: $existing_typeval" + } + lappend output_tomlish $tomlish_record + } + ARRAY { + #UUU + #fragment recursion + puts "update_tomlish_from_dict: process ARRAY fragment" + puts "tomlish:\n$tomlish" + puts "updatedict:\n$d" + set source_d_elements [tomlish::dict::path::get $d {[]}] + + set updated_arraychildren [list] + set arrayrecord $tomlish_record + set arraychildren [lrange $arrayrecord 1 end] ;#includes WS, SEP, NEWLINE, COMMENT + set arridx 0 + set childidx 0 + foreach arrchild $arraychildren { + set arrchild_type [lindex $arrchild 0] + switch -- $arrchild_type { + SEP { + #we don't check for proper SEP interspersal here, presuming well-formed tomlish - review + lappend updated_arraychildren $arrchild + } + NEWLINE - WS - COMMENT { + lappend updated_arraychildren $arrchild + } + default { + #updatables + #review - type changes from existing value?? + set sourcedata [lindex $source_d_elements $arridx] + switch -- $arrchild_type { + STRING - LITERAL - FLOAT - INT - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL { + #basic types - no recursion needed + #REVIEW - change of type? flag to allow/disallow? + if {![tomlish::dict::is_typeval $sourcedata]} { + error "update_tomlish_from_dict - update dictionary has non-leaf data at path \[$arridx\] - cannot set" + } + set newval [dict get $sourcedata value] + set newtype [dict get $sourcedata type] + if {$newtype eq "STRING"} { + set newval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $newval] + } + lappend updated_arraychildren [list $newtype $newval] + } + MULTISTRING { + #no need to recurse + puts stderr "multistring within array update - unimplemented" + } + MULTILITERAL { + #no need to recurse + puts stderr "multiliteral within array update - unimplemented" + } + ITABLE - ARRAY { + #recurse + puts stderr "update $tomlish_type within array" + set nextd [tomlish::dict::path::get $d $arridx] + set subrecord_tomlish [list $arrchild] + set newsubrecord_tomlish [update_tomlish_from_dict $subrecord_tomlish $nextd] + lappend updated_arraychildren {*}$newsubrecord_tomlish + } + default { + error "update_tomlish_from_dict: unexpected array child record type $arrchild_type" + } + } + incr arridx ;#only increment array index for updatables + } + } + } + + lappend output_tomlish [list ARRAY {*}$updated_arraychildren] + } + ITABLE { + #fragment recursion target + #ITABLE {DOTTEDKEY {{KEY j}} = {INT 1}} + #ITABLE {WS { }} {DOTTEDKEY {{KEY j}} = {INT 1} {WS { }} SEP} {WS { }} {DOTTEDKEY {{KEY k} {WS { }}} = {WS { }} {INT 333}} + #ITABLE {NEWLINE lf} {DOTTEDKEY {{KEY j} {WS { }}} = {WS { }} {INT 1} SEP} {WS { }} {COMMENT test} {NEWLINE lf} {WS { }} {DOTTEDKEY {{KEY k}} = {WS { }} {INT 2} {NEWLINE lf}} + puts "update_tomlish_from_dict: process ITABLE fragment" + puts "tomlish:\n$tomlish" + puts "updatedict:\n$d" + set updated_itablechildren [list] + set itablechildren [lrange $tomlish_record 1 end] ;#includes WS, NEWLINE, COMMENT (possibly SEP - though it may be attached to DOTTEDKEY record REVIEW) + #we only expect DOTTEDKEY records for data items within ITABLE + foreach itablechild $tomlish_record { + set itablechild_type [lindex $itablechild 0] + switch -- $itablechild_type { + SEP { + #REVIEW + #we don't necessarily expect a SEP *directly* within ITABLE records as currently when they're created by tomlish::from_toml + #it attaches them (along with intervening WS, COMMENTs) to each DOTTEDKEY record + #This feels somewhat misaligned with ARRAY - where we have no choice but to have SEP, and COMMENTs independent of the array elements. + #Attaching COMMENTs, SEP to the previous DOTTEDKEY has some merit - but perhaps consistency with ARRAY would be preferable. + #This may change - but in any case it should probably be valid/handled gracefully either way. + lappend updated_itablechildren $itablechild + } + COMMENT - WS - NEWLINE { + lappend updated_itablechildren $itablechild + } + DOTTEDKEY { + puts stderr "update dottedkey in itable: tomlish:[list $itablechild] d:$d" + set updatedtomlish [update_tomlish_from_dict [list $itablechild] $d] + set newrecord [lindex $updatedtomlish 0] + lappend updated_itablechildren $newrecord + } + } + } + + lappend output_tomlish [list ITABLE {*}$updated_itablechildren] + } + default { + error "update_tomlish_from_dict: Unexpected toplevel type $tomlish_type record: $tomlish_record" + } + } + } + return $output_tomlish + } + #*** !doctools #[list_end] [comment {--- end definitions namespace tomlish ---}] @@ -1713,7 +2149,7 @@ namespace eval tomlish::build { } proc DATETIME {str} { - if {[::tomlish::utils::is_datetime $str]} { + if {[::tomlish::utils::is_date_or_time_or_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]" @@ -2052,6 +2488,103 @@ namespace eval tomlish::utils { } #------------------------------------------------------------------------------ + #subset of jq syntax for get/set operations on dicts + # no filters or multiple targets + # meant for 'leaf' queries + proc jq_to_path {jq} { + set jq [string trim $jq] ;#don't tokenize any leading/trailing whitespace + set path [list] + set in_arr 0 + set in_dq 0 + set tok "" + set bsl 0 + foreach c [split $jq ""] { + if {$c eq "\\"} { + if {$bsl} { + set bsl 0 + set c "\\" + } else { + set bsl 1 + continue + } + } else { + if {$bsl} { + set c "\\$c" + set bsl 0 + } + } + if {$in_arr} { + switch -- $c { + {]} { + set in_arr 0 + lappend path $tok + set tok "" + } + default { + append tok $c + } + } + } elseif {$in_dq} { + if {$c eq "\""} { + set in_dq 0 + #append tok "\"" + lappend path $tok + set tok "" + } else { + append tok $c + } + } else { + switch -- $c { + . { + if {$tok ne ""} { + lappend path $tok + } + set tok "@@" + } + {[} { + if {$tok ne ""} { + lappend path $tok + } + set in_arr 1 + set tok "" + } + {"} { + if {$tok eq "@@"} { + #set tok "@@\"" + set in_dq 1 + } else { + append tok "\"" + } + } + default { + append tok $c + } + } + } + } + if {$tok ne ""} { + lappend path $tok + } + return $path + } + proc path_to_jq {path} { + set jq "" + foreach p $path { + if {[string match @@* $p]} { + set key [string range $p 2 end] + if {![tomlish::utils::is_barekey $key]} { + set key [subst -nocommands -novariables $key] + set key "\"[tomlish::utils::rawstring_to_Bstring_with_escaped_controls $key]\"" + } + append jq ".$key" + } else { + append jq {[} $p {]} + } + } + return $jq + } + + #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 @@ -2249,16 +2782,78 @@ namespace eval tomlish::utils { return [string map $map $str] } - proc rawstring_is_valid_tomlstring {str} { - #controls are allowed in this direction dict -> toml (they get quoted) + #anything is valid in this direction ?? review + #proc rawstring_is_valid_tomlstring {str} { + # #controls are allowed in this direction dict -> toml (they get quoted) + + # #check any existing escapes are valid + # if {[catch { + # unescape_string $str + # } errM]} { + # return 0 + # } + # return 1 + #} + - #check any existing escapes are valid + #REVIEW - easier way to validate? regex? + #This is not used for the parsing of toml to tomlish, + # but can be used to validate for updating via dict e.g when setting with tomlish::dict::path::setleaf + proc inner_MultiBstring_is_valid_toml {str} { + set without_literal_backslashes [string map [list "\\\\" ""] $str] + #replace only escaped dquotes - use a placeholder - we don't want unescaped runs of dquotes merging. + set without_escaped_dquotes [string map [list "\\\"" ""] $without_literal_backslashes] + + if {[string first "\"\"\"" $without_escaped_dquotes] != -1} { + return 0 + } + #assert - all remaining backslashes are escapes + + #strip remaining dquotes + set dquoteless [string map [list "\"" ""] $without_escaped_dquotes] + #puts stderr "dquoteless: $dquoteless" + + #check any remaining escapes are valid if {[catch { - unescape_string $str + #don't use the returned value - just check it + unescape_string $without_literal_backslashes } errM]} { return 0 } - return 1 + + + variable Bstring_control_map + #remove backslash from control map - we are happy with the remaining escapes (varying length) + set testmap [dict remove $Bstring_control_map "\\" \r \n] + set testval [string map $testmap $dquoteless] + #if they differ - there were raw controls + return [expr {$testval eq $dquoteless}] + } + proc inner_Bstring_is_valid_toml {str} { + set without_literal_backslashes [string map [list "\\\\" ""] $str] + #replace only escaped dquotes - use a placeholder - we don't want unescaped runs of dquotes merging. + set without_escaped_dquotes [string map [list "\\\"" ""] $without_literal_backslashes] + + #plain Bstring can't have unescaped dquotes at tall + if {[string first "\"" $without_escaped_dquotes] != -1} { + return 0 + } + #assert - all remaining backslashes are escapes + + #check any remaining escapes are valid + if {[catch { + #don't use the returned value - just check it + unescape_string $without_literal_backslashes + } errM]} { + return 0 + } + + variable Bstring_control_map + #remove backslash from control map - we are happy with the remaining escapes (varying length) + set testmap [dict remove $Bstring_control_map "\\"] + set testval [string map $testmap $without_escaped_dquotes] + #if they differ - there were raw controls + return [expr {$testval eq $without_escaped_dquotes}] } proc rawstring_is_valid_literal {str} { @@ -2850,48 +3445,9 @@ namespace eval tomlish::utils { } } - proc is_datepart {str} { - set matches [regexp -all {[0-9\-]} $str] - if {[tcl::string::length $str] != $matches} { - return 0 - } - #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) - if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { - return 0 - } - if {$m > 12 || $m == 0} { - return 0 - } - switch -- [expr {$m}] { - 1 - 3 - 5 - 7 - 8 - 10 - 12 { - if {$d > 31 || $d == 0} { - return 0 - } - } - 2 { - if {$d > 29 || $d == 0} { - return 0 - } - if {$d == 29} { - #leapyear check - if {[catch {clock scan $str -format %Y-%m-%d} errM]} { - return 0 - } - } - } - 4 - 6 - 9 - 11 { - if {$d > 30 || $d == 0} { - return 0 - } - } - } - return 1 - } - proc is_localdate {str} { - is_datepart $str - } #allow only hh:mm:ss or hh:mm (no subseconds) + #return 2 when missing seconds proc _is_hms_or_hm_time {val} { set numchars [tcl::string::length $val] if {[regexp -all {[0-9:]} $val] != $numchars} { @@ -2908,6 +3464,7 @@ namespace eval tomlish::utils { if {$hr > 23 || $min > 59} { return 0 } + return 2 ;#missing seconds indicator (can still be used as boolean for true in tcl if we don't care whether hh::mm::ss or hh:mm } elseif {[llength $hms_cparts] == 3} { lassign $hms_cparts hr min sec if {[string length $hr] != 2 || [string length $min] != 2 || [string length $sec] !=2} { @@ -2917,10 +3474,10 @@ namespace eval tomlish::utils { if {$hr > 23 || $min > 59 || $sec > 60} { return 0 } + return 1 } else { return 0 } - return 1 } proc is_timepart {str} { #validate the part after the T (or space) @@ -2946,6 +3503,11 @@ namespace eval tomlish::utils { } if {[llength $dotparts] == 2} { lassign $dotparts hms tail + if {[_is_hms_or_hm_time $hms] == 2} { + #If we have a dot - assume hh::mm::ss required + #toml spec is unclear on this but hh:mm. doesn't seem sensible - REVIEW + return 0 + } #validate tail - which might have +- offset if {[string index $tail end] ni {z Z}} { #from hh:mm:??. @@ -2954,14 +3516,21 @@ namespace eval tomlish::utils { if {![string is digit -strict $fraction]} { return 0 } - if {![_is_hms_or_hm_time $offset]} { + if {[_is_hms_or_hm_time $offset] != 2} { + #RFC3339 indicates offset can be specified as hh:mm or Z - not hh:mm:ss + return 0 + } + } else { + #tail has no +/-, only valid if fraction digits + #toml-test invalid/datetime/second-trailing-dot + if {![string is digit -strict $tail]} { return 0 } } } else { set tail [string range $tail 0 end-1] #expect tail nnnn (from hh:mm::ss.nnnnZ) - #had a dot and a zZ - no other offset valid (?) + #had a dot and a zZ if {![string is digit -strict $tail]} { return 0 } @@ -2970,8 +3539,10 @@ namespace eval tomlish::utils { } else { #no dot (fraction of second) if {[regexp {(.*)[+-](.*)} $str _match hms offset]} { - #validate offset - if {![_is_hms_or_hm_time $offset]} { + #validate offset + #offset of +Z or -Z not valid + if {[_is_hms_or_hm_time $offset] != 2} { + #offset is not of required form hh:mm return 0 } } else { @@ -2994,7 +3565,45 @@ namespace eval tomlish::utils { return 0 } } - proc is_localtime {str} { + + proc is_date-local {str} { + set matches [regexp -all {[0-9\-]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) + if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { + return 0 + } + if {$m > 12 || $m == 0} { + return 0 + } + switch -- [expr {$m}] { + 1 - 3 - 5 - 7 - 8 - 10 - 12 { + if {$d > 31 || $d == 0} { + return 0 + } + } + 2 { + if {$d > 29 || $d == 0} { + return 0 + } + if {$d == 29} { + #leapyear check + if {[catch {clock scan $str -format %Y-%m-%d} errM]} { + return 0 + } + } + } + 4 - 6 - 9 - 11 { + if {$d > 30 || $d == 0} { + return 0 + } + } + } + return 1 + } + proc is_time-local {str} { #time of day without any relation to a specific day or any offset or timezone set numchars [tcl::string::length $str] if {[regexp -all {[0-9\.:]} $str] == $numchars} { @@ -3023,9 +3632,26 @@ namespace eval tomlish::utils { return 0 } } - - #review + proc is_datetime-local {str} { + set norm [string map {" " T} $str] + lassign [split $norm T] dp tp + if {$dp eq "" || $tp eq ""} {return 0} + if {![is_date-local $dp]} {return 0} + if {![is_timepart $tp]} {return 0} + if {![is_time-local $tp]} {return 0} + return 1 + } proc is_datetime {str} { + set norm [string map {" " T} $str] + lassign [split $norm T] dp tp + if {$dp eq "" || $tp eq ""} {return 0} + if {![is_date-local $dp]} {return 0} + if {![is_timepart $tp]} {return 0} + if {[is_time-local $tp]} {return 0} + return 1 + } + #review + proc is_date_or_time_or_datetime {str} { #Essentially RFC3339 formatted date-time - but: #1) allowing seconds to be omitted (:00 assumed) #2) T may be replaced with a single space character TODO - parser support for space in datetime! @@ -3073,7 +3699,7 @@ namespace eval tomlish::utils { if {[string first T $str] > -1} { lassign [split $str T] datepart timepart - if {![is_datepart $datepart]} { + if {![is_date-local $datepart]} { return 0 } if {![is_timepart $timepart]} { @@ -3083,7 +3709,7 @@ namespace eval tomlish::utils { #either a datepart or a localtime #spec: "If you include only the time portion of an RFC 3339 formatted date-time, it will represent that time of day # without any relation to a specific day or any offset or timezone." - if {!([is_datepart $str] || [is_localtime $str])} { + if {!([is_date-local $str] || [is_time-local $str])} { return 0 } } @@ -6029,7 +6655,7 @@ namespace eval tomlish::huddle { set h [huddle::json::json2huddle parse $json] } proc from_dict {d} { - + error "tomlish::huddle::from_dict unimplemented" } #raw - strings must already be processed into values suitable for json e.g surrogate pair escaping @@ -6625,8 +7251,40 @@ namespace eval tomlish::dict { set testtype integer set dval [expr {$dval}] ;#convert e.g 0xDEADBEEF to 3735928559 } - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - FLOAT - BOOL { - #DDDD + FLOAT - BOOL { + set testtype [string tolower $dtype] + } + DATE-LOCAL { + set testtype date-local + } + TIME-LOCAL { + if {[tomlish::utils::_is_hms_or_hm_time $dval] == 2} { + #add seconds for sending to json + set dval "${dval}:00" + } + set testtype time-local + } + DATETIME - DATETIME-LOCAL { + #we expect it to be basically well formed here - this is not validation - just adding possible missing seconds + if {![regexp {([tT\ ])} $dval _ dsep]} { + return -code error -errorcode {TOJSON SYNTAX INVALIDDATE} "Unable to process $dtype '$dval' - missing RFC3339 separator space or T" + } + lassign [split $dval $dsep] dp tail + + #toml allows HH:MM without seconds - but we need to add seconds 00 when passing to external systems + if {![tomlish::utils::is_time-local $tail]} { + #there is some offset component. We aren't checking its syntax here (presumed done when dict building) + regexp {([\+\-zZ])} $tail _ tsep ;#keep tsep for rebuilding + lassign [split $tail $tsep] tp offset ;#offset may be empty if z or Z + } else { + set tp $tail + set tsep "" + set offset "" + } + if {[tomlish::utils::_is_hms_or_hm_time $tp] == 2} { + #need to add seconds + set dval "${dp}${dsep}${tp}:00${tsep}${offset}" + } set testtype [string tolower $dtype] } STRING - MULTISTRING { @@ -6644,10 +7302,6 @@ namespace eval tomlish::dict { #} set dval [tomlish::utils::rawstring_to_jsonstring $dval] } - MULTILITERAL { - #todo - escape newlines for json? - set testtype string - } default { error "convert_typeval_to_tomltest unhandled type $dtype" } @@ -6882,7 +7536,7 @@ namespace eval tomlish::dict { lappend dottedtables_defined $dottedsuper_refpath #ensure empty tables are still represented in the datastructure - tomlish::dict::path::set_endpoint datastructure $dottedsuper_refpath {} ;#set to empty subdict + tomlish::dict::path::setleaf datastructure $dottedsuper_refpath {} 0;#set to empty subdict } else { #added for fixed assumption set ttype [dict get $tablenames_info $dottedsuper_refpath ttype] @@ -6935,7 +7589,7 @@ namespace eval tomlish::dict { #'create' the table dict set tablenames_info $dottedkey_refpath ttype dottedkey_table #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list - tomlish::dict::path::set_endpoint datastructure $dottedkey_refpath {} + tomlish::dict::path::setleaf datastructure $dottedkey_refpath {} 0 lappend dottedtables_defined $dottedkey_refpath # @@ -6994,7 +7648,7 @@ namespace eval tomlish::dict { #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_typeval can distinguish tomlish::log::debug "_process_tomlish_dottedkey>>> context:$context_refpath dottedkey $dottedkeyname kv: $keyval_dict" - tomlish::dict::path::set_endpoint datastructure $fullkey_refpath $keyval_dict + tomlish::dict::path::setleaf datastructure $fullkey_refpath $keyval_dict 0 #remove ? #if {![tomlish::dict::is_typeval $keyval_dict]} { @@ -7015,8 +7669,17 @@ namespace eval tomlish::dict { #} return [dict create dottedtables_defined $dottedtables_defined] } + + #tomlish::dict::from_tomlish is a *basic* programmatic datastructure for accessing the data. # produce a dictionary of keys and values from a tomlish tagged list. + # ---------------------------------------------------------------- + # NOTE: + # can instead produce a list if passed an ARRAY at toplevel + # can produce a single value if passed a MULTISTRING or MULTILIST at toplevel + # These are fragments of tomlish used in recursive calls. + # Such fragments don't represent valid tomlish that can be converted to a toml doc. + # ---------------------------------------------------------------- # dict::from_tomlish is primarily for read access to 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. @@ -7036,7 +7699,7 @@ namespace eval tomlish::dict { # versus #[Data] #temps = [{cpu = 79.5, case = 72.0}] - proc from_tomlish {tomlish} { + proc from_tomlish {tomlish {returnextra 0}} { package require dictn #keep track of which tablenames have already been directly defined, @@ -7099,13 +7762,17 @@ namespace eval tomlish::dict { #value is a dict with keys: ttype, tdefined } + if {![string is list $tomlish]} { + error "tomlish::dict::from_tomlish Supplied value for tomlish does not appear to be a tomlish list. Use tomlish::from_toml to get a tomlish list from toml." + } + log::info "---> dict::from_tomlish processing '$tomlish'<<<" set items $tomlish foreach lst $items { if {[lindex $lst 0] ni $::tomlish::tags} { - error "supplied list 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" + error "tomlish::dict::from_tomlish supplied list 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" } } @@ -7121,12 +7788,13 @@ namespace eval tomlish::dict { #puts "...> item:'$item' tag:'$tag'" switch -exact -- $tag { KEY - DQKEY - SQKEY - INT - FLOAT - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - STRING - LITERAL { - #why would we get individual key item as opposed to DOTTEDKEY? + #we don't require invalid tomlish fragments with these keys in our direct recursion + #(we do support ARRAY, MULTISTING, and MULTILITERAL tomlish fragments below) error "tomlish::dict::from_tomlish error: invalid tag: $tag. At the toplevel, from_tomlish can only process WS NEWLINE COMMENT and compound elements DOTTEDKEY TABLE TABLEARRAY ITABLE MULTILITERAL MULTISTRING" } DOTTEDKEY { - #toplevel dotted key - set dkinfo [_process_tomlish_dottedkey $item] + #toplevel dotted key empty context_refpath + set dkinfo [_process_tomlish_dottedkey $item {}] lappend dottedtables_defined {*}[dict get $dkinfo dottedtables_defined] #at any level - we don't expect any more DOTTEDKEY records in a tomlish structure after TABLE or TABLEARRAY are encountered #as those records should encapsulate their own dottedkeys @@ -7221,7 +7889,7 @@ namespace eval tomlish::dict { dict set tablenames_info $tablearray_refpath ttype header_tablearray #dict set datastructure {*}$norm_segments [list type ARRAY value {}] #create array along with empty array-item at position zero - tomlish::dict::path::set_endpoint datastructure $tablearray_refpath [list type ARRAY value {{}}] + tomlish::dict::path::setleaf datastructure $tablearray_refpath [list type ARRAY value {{}}] 0 set arrayitem_refpath [list {*}$tablearray_refpath 0] #set ARRAY_ELEMENTS [list] } else { @@ -7375,7 +8043,7 @@ namespace eval tomlish::dict { dict set tablenames_info $refpath ttype unknown_header #ensure empty tables are still represented in the datastructure #dict set datastructure {*}$supertable [list] - tomlish::dict::path::set_endpoint datastructure $refpath {} + tomlish::dict::path::setleaf datastructure $refpath {} 0 } else { #supertable has already been created - and may be defined - but even if defined we can add subtables unless it is of type itable if {[dict get $tablenames_info $refpath ttype] eq "header_tablearray"} { @@ -7420,7 +8088,7 @@ namespace eval tomlish::dict { #We are 'defining' this table's keys and values here (even if empty) #dict set datastructure {*}$norm_segments [list] ;#ensure table still represented in datastructure even if we add no keyvals here - tomlish::dict::path::set_endpoint datastructure $table_refpath {} ;#ensure table still represented in datastructure even if we add no keyvals here + tomlish::dict::path::setleaf datastructure $table_refpath {} 0;#ensure table still represented in datastructure even if we add no keyvals here } else { if {[dict get $tablenames_info $table_refpath ttype] eq "header_tablearray"} { #e.g tomltest invalid/table/duplicate-table-array2 @@ -7492,6 +8160,7 @@ namespace eval tomlish::dict { } } ARRAY { + #invalid at toplevel of a 'complete' tomlish structure - but we support it here for recursive fragment processing #arrays in toml are allowed to contain mixtures of types set datastructure [list] log::debug "--> processing array: $item" @@ -7540,6 +8209,8 @@ namespace eval tomlish::dict { } } MULTILITERAL { + #Not for toplevel of complete tomlish - (recursive fragment processing) + #triple squoted string #first newline stripped only if it is the very first element #(ie *immediately* following the opening delims) @@ -7583,6 +8254,7 @@ namespace eval tomlish::dict { set datastructure $stringvalue } MULTISTRING { + #Not for toplevel of complete tomlish - (recursive fragment processing) #triple dquoted string log::debug "---> tomlish::dict::from_tomlish processing multistring: $item" set stringvalue "" @@ -7696,82 +8368,394 @@ namespace eval tomlish::dict { } } } - return $datastructure + if {!$returnextra} { + return $datastructure + } else { + return [dict create datastructure $datastructure tablenames_info $tablenames_info] + } + } +} +namespace eval tomlish::path { + namespace export {[a-z]*}; # Convention: export all lowercase + + set test_tomlish [tomlish::from_toml { } #comment {z=1} {x.y=2 #xy2} {[[shop.product]] #product1} {x=[ #array1} {11 #val1} {, 12 #val2} {]} {[unrelated.' etc ']} {a.b={c=666}} {a.x={}} {[[shop.product]]} {x="test"} {[shop]} {name="myshop"}] + + proc get {tomlish {path {}}} { + if {$path eq ""} { + return $tomlish + } + if {[string index $path 0] in [list . "\["]} { + set path [tomlish::utils::jq_to_path $path] + } + + #at the cost of some performance, sanity check that the tomlish is valid + if {[catch {tomlish::to_dict $tomlish} d]} { + error "tomlish::path::get error supplied tomlish is malformed\nerrmsg: $d" + } + #since we have the dict - test the path is valid + if {![tomlish::dict::path::exists $d $path]} { + error "tomlish::path::get - path \"$path\" not found in tomlish $tomlish" + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + set tomlish [lrange $tomlish 1 end] + } + ::set pathsofar [list] + ::set tomlitems [list] ;#reducing set. 2 element list {keypath itemlist} + foreach record $tomlish { + lappend tomlitems [list {} [list $record]] ;#root records + } + + ::set dictsubpath [list] ;#reset at every index encounter? + foreach p $path { + ::lappend pathsofar $p + set sublist [list] + if {[string range $p 0 1] eq "@@"} { + set realsearchkey [string range $p 2 end] + lappend dictsubpath $realsearchkey + foreach path_items $tomlitems { + lassign $path_items subpath tlist + lappend subpath $realsearchkey + foreach item $tlist { + set tp [lindex $item 0] + switch -- $tp { + WS - NEWLINE - COMMENT { + } + DOTTEDKEY { + #can occur at toplevel (before others) or within other elements + set keyinfo [tomlish::get_dottedkey_info $item] + set keys_raw [dict get $keyinfo keys_raw] + puts stderr "subpath:$subpath -->DOTTEDKEY keys_raw: $keys_raw" + #may not be enough keys_raw for subpath - but there could be further ITABLES to continue the dict further + set prefixparts [lrange $keys_raw 0 [llength $subpath]-1] + set is_kmatch 1 ;#default assumption only + foreach dsub $subpath kpart $prefixparts { + if {$dsub ne $kpart} { + set is_kmatch 0 + } + } + if {$is_kmatch} { + if {[llength $keys_raw] == [llength $subpath]} { + set subpath [list] + #e.g {DOTTEDKEY {{KEY xxx}} = {WS { }} {STRING blah}} + lappend sublist [list $subpath [lrange $item 3 end]] + } else { + lappend sublist [list $subpath [list $item]] + } + } + } + ITABLE { + #subelement only + set itablechildren [lrange $item 1 end] + puts stderr "subpath:$subpath -->ITABLE records: $itablechildren" + set nextpath [lmap v $subpath {string cat @@ $v}] + set results [tomlish::path::get $itablechildren $nextpath] + set subpath [list] + puts "--> lappending [list $subpath $results]" + lappend sublist [list $subpath $results] + } + TABLEARRAY { + #toplevel only + set fulltablename [lindex $item 1] + set normalise 1 + set tparts [tomlish::toml::tablename_split $fulltablename $normalise] + if {[llength $tparts] < [llength $subpath]} {continue} ;#not enough parts to satisfy current subpath query + set prefixparts [lrange $tparts 0 [llength $subpath]-1] + set is_tmatch 1 ;#default assumption only + foreach dsub $subpath tpart $prefixparts { + if {$dsub ne $tpart} { + set is_tmatch 0 + } + } + #TODO reference arrays + if {$is_tmatch} { + if {[llength $tparts] == [llength $subpath]} { + set subpath [list] + lappend sublist [list $subpath [lrange $item 2 end]] + } else { + #TODO + set subpath 0 + lappend sublist [list $subpath [list $item]] ;#add entire TABLE line + } + } + } + TABLE { + #toplevel only + set fulltablename [lindex $item 1] + set normalise 1 + set tparts [tomlish::toml::tablename_split $fulltablename $normalise] + if {[llength $tparts] < [llength $subpath]} {continue} ;#not enough parts to satisfy current subpath query + set prefixparts [lrange $tparts 0 [llength $subpath]-1] + set is_tmatch 1 ;#default assumption only + foreach dsub $subpath tpart $prefixparts { + if {$dsub ne $tpart} { + set is_tmatch 0 + } + } + if {$is_tmatch} { + if {[llength $tparts] == [llength $subpath]} { + set subpath [list] + lappend sublist [list $subpath [lrange $item 2 end]] + } else { + #leave subpath + lappend sublist [list $subpath [list $item]] ;#add entire TABLE line + } + } + } + ARRAY { + #subelement only + } + + } + } + } + } else { + #index + #will never occur at toplevel (dict::path::exists already ruled it out) + foreach path_items $toml_items { + lassign $path_items subpath $tlist + set tp [lindex $tlist 0] + switch -- $tp { + ARRAY { + } + } + } + } + #temp + puts stdout "pathsofar: $pathsofar" + puts stdout [punk::lib::showdict -roottype list $sublist] + set tomlitems $sublist + } + + #REVIEW + if {[llength $tomlitems] == 1} { + return [lindex $tomlitems 0 1] + } + set result [list] + foreach i $tomlitems { + lappend result [lindex $i 1] + } + return $result + #return [lindex $tomlitems 1] } + } namespace eval tomlish::dict::path { - #access tomlish dict structure + + #access tomlish dict structure namespace export {[a-z]*}; # Convention: export all lowercase - #access with path such as: @@k @@k 0 @@k end where dict keys marked with @@ and plain values are list indices into in {type ARRAY value } - #leaf elements returned as structured {type value } + #access with path such as: @@k @@k 0 @@k end where dict keys marked with @@ and plain values are list indices into in {type ARRAY value } + #leaf elements returned as structured {type value } proc get {dictval {path {}}} { if {$path eq ""} { return $dictval } + if {[string index $path 0] in [list . "\["]} { + set path [tomlish::utils::jq_to_path $path] + } + ::set data $dictval ::set pathsofar [list] + ::set i 0 foreach p $path { ::lappend pathsofar $p if {[string range $p 0 1] eq "@@"} { + #dict key ::set data [dict get $data [string range $p 2 end]] } else { - if {![tomlish::dict::is_typeval $data]} { - error "tomlish::dict::path::get error bad path $path. Attempt to access table as array at subpath $pathsofar." - } - if {[dict get $data type] ne "ARRAY"} { - error "tomlish::dict::get error bad path $path. Subpath $pathsofar is not an array." + #ARRAY or raw list index + if {[llength $pathsofar] > 1 && [string trim [lindex $pathsofar $i-1]] eq ""} { + #previous path was query for entire list - result is a raw list, not a dict + if {[string trim $p] eq ""} { + #review - multiple {[]} in a row in the path is pretty suspicious - raise error + error "tomlish::dict::path::get error - multiple empty indices in a row not supported" + } + ::set data [lindex $data $p] + } else { + if {![tomlish::dict::is_typeval $data]} { + error "tomlish::dict::path::get error bad path $path. Attempt to access table or other value as array at subpath $pathsofar." + } + if {[dict get $data type] ne "ARRAY"} { + error "tomlish::dict::get error bad path $path. Subpath $pathsofar is not an array." + } + ::set arrdata [dict get $data value] + #when $p is empty string (or whitespace) - lindex returns entire list (or empty list) + # - this corresponds to jq: {[]} or path {""} + ::set data [lindex $arrdata $p] } - ::set arrdata [dict get $data value] - ::set data [lindex $arrdata $p] } + incr i } return $data } + proc exists {dictval path} { + #completely empty path considered to exist - review + if {[string index $path 0] in [list . {[}]} { + set path [tomlish::utils::jq_to_path $path] + } ::set data $dictval ::set pathsofar [list] ::set exists 1 + ::set i 0 foreach p $path { ::lappend pathsofar $p if {[string range $p 0 1] eq "@@"} { + #dict key ::set k [string range $p 2 end] if {![dict exists $data $k]} { return 0 } ::set data [dict get $data $k] } else { - if {![tomlish::dict::is_typeval $data]} { - return 0 + #ARRAY or raw list index + if {[llength $pathsofar] > 1 && [string trim [lindex $pathsofar $i-1]] eq ""} { + #previous path was query for entire list - result is not a dict + if {[string trim $p] eq ""} { + #review - multiple {[]} in a row in the path is pretty suspicious - raise error + error "tomlish::dict::path::exists error - multiple empty indices in a row not supported" + #or just leave data as is? + } else { + ::set intp [tomlish::system::lindex_resolve_basic $data $p] + if {$intp == -1} { + return 0 + } + ::set data [lindex $data $p] + } + } else { + if {![tomlish::dict::is_typeval $data]} { + return 0 + } + if {[dict get $data type] ne "ARRAY"} { + return 0 + } + #special case for empty path syntax {jq: [] path: ""} meaning retrieve all elements in list + ::set arrdata [dict get $data value] + if {[string trim $p] eq ""} { + #we have confirmed above it is an ARRAY - we consider an empty list to exist. + #UUU + ::set data $arrdata + } else { + #for 'exists' we need to avoid lindex returning empty string for out of bounds + ::set intp [tomlish::system::lindex_resolve_basic $arrdata $p] ;#handle index math (end-1 etc) + if {$intp == -1} { + #out of bounds + return 0 + } + ::set data [lindex $arrdata $p] + } } - if {[dict get $data type] ne "ARRAY"} { - return 0 + } + incr i + } + return $exists + } + + + #raise error for invalid + proc validate_typeval {typeval} { + set valtype [dict get $typeval type] + set rawval [dict get $typeval value] + switch -- $valtype { + INT { + if {![tomlish::utils::is_int $rawval]} { + return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml int: '$rawval'" } - ::set arrdata [dict get $data value] - ::set intp [tomlish::system::lindex_resolve_basic $arrdata $p] ;#handle index math (end-1 etc) - if {$intp == -1} { - #out of bounds - return 0 + } + BOOL { + #toml only accepts lower case true and false + #review + if {$rawval ni {true false}} { + return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml boolean (true|false): '$rawval'" + } + } + FLOAT { + if {![tomlish::utils::is_float $rawval]} { + return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml float: '$rawval'" + } + } + DATETIME { + #review - accept even when more specific types apply? + if {![tomlish::utils::is_datetime]} { + return -code error -errorcode {TOML TYPE NOT_DATETIME} "validate_typeval value is not a valid toml datetime: '$rawval'" + } + } + DATETIME-LOCAL { + if {![tomlish::utils::is_datetime-local]} { + return -code error -errorcode {TOML TYPE NOT_DATETIME-LOCAL} "validate_typeval value is not a valid toml datetime-local: '$rawval'" + } + } + DATE-LOCAL { + if {![tomlish::utils::is_date-local]} { + return -code error -errorcode {TOML TYPE NOT_DATE-LOCAL} "validate_typeval value is not a valid toml date-local: '$rawval'" + } + } + TIME-LOCAL { + if {![tomlish::utils::is_time-local]} { + return -code error -errorcode {TOML TYPE NOT_TIME-LOCAL} "validate_typeval value is not a valid toml time-local: '$rawval'" + } + } + ARRAY { + if {$rawval eq ""} { + return + } + foreach el $rawval { + validate_typeval $el + } + } + STRING { + if {![tomlish::utils::inner_Bstring_is_valid_toml $rawval]} { + return -code error -errorcode {TOML TYPE NOT_BSTRING} "validate_typeval value is not a valid toml basic string: '$rawval'" } - ::set data [lindex $arrdata $p] + } + MULTISTRING { + #multistring as a single value + #UUU + if {![tomlish::utils::inner_MultiBstring_is_valid_toml $rawval]} { + return -code error -errorcode {TOML TYPE NOT_MLBSTRING} "validate_typeval value is not a valid toml multistring: '$rawval'" + } + } + LITERAL { + #todo? + } + MULTILITERAL { + #? + } + default { + return -code error -errorcode {TOML TYPE UNRECOGNISED} "validate_typeval does not recognise type '$valtype'" } } - return $exists } #a restricted analogy of 'dictn set' - #set 'endpoints' - don't create intermediate paths + #set 'leaf' values only - don't create intermediate paths # can replace an existing dict with another dict # can create a key when key at tail end of path is a key (ie @@keyname, not index) # can replace an existing {type value value } # with added restriction that if is ARRAY the new must also be ARRAY - proc set_endpoint {dictvariable path value} { + + package require struct::list + proc setleaf {dictvariable path value {validate 1}} { + if {[string index $path 0] in [list . {[}]} { + set path [tomlish::utils::jq_to_path $path] + } + upvar $dictvariable dict_being_edited + if {![info exists dict_being_edited]} { + error "tomlish::dict::path::setleaf error - supplied value for 'dictvariable' doesn't seem to be the name of an existing variable" + } ::set data $dict_being_edited ::set pathsofar [list] if {!([tomlish::dict::is_typeval $value] || [tomlish::dict::is_typeval_dict $value 0])} { #failed check of supplied value as basic type, or a sub-dict structure (not checking arrays) - error "tomlish::dict::path::set_endpoint error - value must already be in the tomlish form {type value } or be a dict with such forms as leaves" + error "tomlish::dict::path::setleaf error - value must already be in the tomlish form {type value } or be a dict with such forms as leaves" + } + if {$validate && [tomlish::dict::is_typeval $value]} { + #validate value element of $value is correct for type element + if {[catch {validate_typeval $value} errM]} { + return -code error -errorcode {TOMLISH VALIDATION TYPEFAIL} $errM + } } foreach p $path { ::lappend pathsofar $p @@ -7783,28 +8767,28 @@ namespace eval tomlish::dict::path { #} ::set varname v[incr v] - if {$pathsofar eq $path} { - #see if endpoint of the path given already exists + if {[struct::list equal $pathsofar $path]} { + #see if leaf of the path given already exists if {[dict exists $data $k]} { ::set endpoint [dict get $data $k] if {[tomlish::dict::is_typeval $endpoint]} { set existing_tp [dict get $endpoint type] if {![tomlish::dict::is_typeval $value]} { - error "tomlish::dict::path::set_endpoint error Unable to overwrite subpath '$pathsofar' which is of type $existing_tp with sub-dict. Supplied value not {type value value val } with sub-dict: $value" + error "tomlish::dict::path::setleaf error path '$path'. Cannot overwrite {type val } with sub-dict: $value" } switch -- [dict get $endpoint type] { ARRAY { #disallow overwriting array - unless given value is an ARRAY? REVIEW if {[dict get $value type] ne "ARRAY"} { - error "tomlish::dict::path::set_endpoint error bad path '$path'. Cannot overwrite array with non-array: $value" + error "tomlish::dict::path::setleaf error bad path '$path'. Cannot overwrite array with non-array: $value" } } default { @@ -7855,9 +8839,9 @@ namespace eval tomlish::dict::path { } } } else { - #endpoint is a typeval dict not a plain typeval - only allow overwrite with a typeval dict + #leaf is a typeval dict not a plain typeval - only allow overwrite with a typeval dict if {![tomlish::dict::is_typeval_dict $value 0]} { - error "tomlish::dict::path::set_endpoint error path '$path'. Cannot overwrite sub-dict (size: [dict size $endpoint]) with non sub-dict: $value" + error "tomlish::dict::path::setleaf error path '$path'. Cannot overwrite sub-dict (size: [dict size $endpoint]) with non sub-dict: $value" } } ::set $varname $value @@ -7867,7 +8851,7 @@ namespace eval tomlish::dict::path { ::set arrdata [dict get $data value] set idx [tomlish::system::lindex_resolve_basic $arrdata $p] if {$idx == -1} { - error "tomlish::dict::path::set_endpoint error bad path '$path'. No existing element at $p" + error "tomlish::dict::path::setleaf error bad path '$path'. No existing element at $p" } ::set data [lindex $arrdata $p] ::set $varname $data @@ -7897,7 +8881,7 @@ namespace eval tomlish::dict::path { if {[string match @@* $k]} { #dict key #dict set $nextvarname $k $newval - set_endpoint $nextvarname [list $k] $newval + setleaf $nextvarname [list $k] $newval 0 } else { #list index ::set nextarr [dict get $nextval value] @@ -7913,6 +8897,9 @@ namespace eval tomlish::dict::path { #path must be to a {type ARRAY value } #REVIEW - how to lappend to deep mixed dict/array structure without rewriting whole datastructure? proc lappend {dictvariable path args} { + if {[string index $path 0] in [list . {[}]} { + set path [tomlish::utils::jq_to_path $path] + } upvar $dictvariable dict_being_edited ::set data $dict_being_edited ::set pathsofar [list] @@ -7933,7 +8920,7 @@ namespace eval tomlish::dict::path { } ::set varname v[incr v] - if {$pathsofar eq $path} { + if {[struct::list equal $pathsofar $path]} { #see if endpoint of the path given is an ARRAY ::set endpoint [dict get $data $k] if {![tomlish::dict::is_typeval $endpoint]} { @@ -7961,7 +8948,7 @@ namespace eval tomlish::dict::path { error "tomlish::dict::path::lappend error bad path $path. Subpath $pathsofar is not an array." } ::set varname v[incr v] - if {$pathsofar eq $path} { + if {[struct::list equal $pathsofar $path]} { if {[dict get $data type] ne "ARRAY"} { error "tomlish::dict::path::lappend error bad path $path. Parent path is not an array." } @@ -8160,6 +9147,8 @@ tcl::namespace::eval tomlish::app { #review chan configure $ch_input -translation lf + chan configure $ch_output -translation lf + if {[catch { set json [read $ch_input] }]} { @@ -8291,6 +9280,25 @@ namespace eval tomlish::system { } } + #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features + #safe in that we don't evaluate the expression as a string. + proc offset_expr {expression} { + #required for tcl < 8.7 range command (lseq not available) + set expression [tcl::string::map {_ {}} $expression] + if {[tcl::string::is integer -strict $expression]} { + return [expr {$expression}] + } + if {[regexp {(.*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { + if {$op eq "-"} { + return [expr {$a - $b}] + } else { + return [expr {$a + $b}] + } + } else { + error "bad expression '$expression': must be integer?\[+-\]integer?" + } + } + if {[info commands ::lseq] ne ""} { #tcl 8.7+ lseq significantly faster, especially for larger ranges #The internal rep can be an 'arithseries' with no string representation diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 5b45b2bc..c7207cc0 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -103,7 +103,9 @@ tcl::namespace::eval punk::aliascore { #use absolute ns ie must be prefixed with :: #single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased - #functions must be in export list of their source namespace + #functions should generally be covered by one of the export patterns of their source namespace + # - if they are not - e.g (separately loaded ensemble command ?) + # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. set aliases [tcl::dict::create\ val ::punk::pipe::val\ aliases ::punk::lib::aliases\ @@ -122,8 +124,8 @@ tcl::namespace::eval punk::aliascore { stripansi ::punk::ansi::ansistrip\ ansiwrap ::punk::ansi::ansiwrap\ colour ::punk::console::colour\ - ansi ::punk::console::ansi\ color ::punk::console::colour\ + ansi ::punk::console::ansi\ a? ::punk::console::code_a?\ A? {::punk::console::code_a? forcecolor}\ a+ ::punk::console::code_a+\ @@ -132,6 +134,7 @@ tcl::namespace::eval punk::aliascore { A {::punk::console::code_a forcecolour}\ smcup ::punk::console::enable_alt_screen\ rmcup ::punk::console::disable_alt_screen\ + config ::punk::config\ ] #*** !doctools @@ -153,6 +156,35 @@ tcl::namespace::eval punk::aliascore { # return "ok" #} + proc _is_exported {ns cmd} { + set exports [::tcl::namespace::eval $ns [list namespace export]] + set is_exported 0 + foreach p $exports { + if {[string match $p $cmd]} { + set is_exported 1 + break + } + } + return $is_exported + } + + #_nsprefix accepts entire command - not just an existing namespace for which we want the parent + proc _nsprefix {{nspath {}}} { + #maintenance: from punk::ns::nsprefix - (without unnecessary nstail) + #normalize the common case of :::: + set nspath [string map {:::: ::} $nspath] + set rawprefix [string range $nspath 0 end-[string length [namespace tail $nspath]]] + if {$rawprefix eq "::"} { + return $rawprefix + } else { + if {[string match *:: $rawprefix]} { + return [string range $rawprefix 0 end-2] + } else { + return $rawprefix + } + } + } + #todo - options as to whether we should raise an error if collisions found, undo aliases etc? proc init {args} { set defaults {-force 0} @@ -195,6 +227,7 @@ tcl::namespace::eval punk::aliascore { error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" } + set failed [list] set tempns ::temp_[info cmdcount] ;#temp ns for renames dict for {a cmd} $aliases { #puts "aliascore $a -> $cmd" @@ -206,16 +239,36 @@ tcl::namespace::eval punk::aliascore { } else { if {[tcl::info::commands $cmd] ne ""} { #todo - ensure exported? noclobber? - if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { + set container_ns [_nsprefix $cmd] + set cmdtail [tcl::namespace::tail $cmd] + set was_exported 1 ;#assumption + if {![_is_exported $container_ns $cmdtail]} { + set was_exported 0 + set existing_exports [tcl::namespace::eval $container_ns [list ::namespace export]] + tcl::namespace::eval $container_ns [list ::namespace export $cmdtail] + } + if {[tcl::namespace::tail $a] eq $cmdtail} { #puts stderr "importing $cmd" - tcl::namespace::eval :: [list namespace import $cmd] + try { + tcl::namespace::eval :: [list ::namespace import $cmd] + } trap {} {emsg eopts} { + lappend failed [list alias $a target $cmd errormsg $emsg] + } } else { #target command name differs from exported name #e.g stripansi -> punk::ansi::ansistrip #import and rename #puts stderr "importing $cmd (with rename to ::$a)" - tcl::namespace::eval $tempns [list namespace import $cmd] - catch {rename ${tempns}::[namespace tail $cmd] ::$a} + try { + tcl::namespace::eval $tempns [list ::namespace import $cmd] + } trap {} {emsg eopst} { + lappend failed [list alias $a target $cmd errormsg $emsg] + } + catch {rename ${tempns}::$cmdtail ::$a} + } + #restore original exports + if {!$was_exported} { + tcl::namespace::eval $container_ns [list ::namespace export -clear {*}$existing_exports] } } else { interp alias {} $a {} {*}$cmd @@ -223,7 +276,7 @@ tcl::namespace::eval punk::aliascore { } } #tcl::namespace::delete $tempns - return [dict create aliases [dict keys $aliases] unchanged $ignore_aliases changed $conflicts] + return [dict create aliases [dict keys $aliases] existing $existing ignored $ignore_aliases changed $conflicts failed $failed] } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 61a454fa..fcbf6ada 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3357,9 +3357,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend PUNKARGS [list { @id -id ::punk::ansi::ansiwrap @cmd -name punk::ansi::ansiwrap -help\ - "Wrap a string with ANSI codes from + {Wrap a string with ANSI codes from supplied codelist(s) followed by trailing - ANSI reset. + ANSI reset. The wrapping is done such that + after every reset in the supplied text, the + default goes back to the supplied codelist. + e.g1 in the following + ansiwrap red bold "rrr[a+ green]ggg[a]rrr" + both strings rrr will be red & bold + + e.g2 bolding and underlining specific text whilst dimming the rest + ansiwrap dim [string map [list test [ansiwrap bold underline test]] "A test string"] + + e.g3 reverse render a complex ansi substring + ansiwrap reverse [textblock::periodic] Codes are numbers or strings as indicated in the output of the colour information @@ -3372,41 +3383,172 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu For finer control use the a+ and a functions eg - set x \"[a+ red]text [a+ bold]etc[a]\" - " + set x "[a+ red]text [a+ bold]etc[a]" + } @leaders -min 0 -max -1 codelist -multiple 1 -default {} -type list -help\ "ANSI names/ints as understood by 'a?' (Not actual ANSI as output by a+) These can be supplied individually or as a list or lists" + @opts + -rawansi -type ansi -default "" + -resetcodes -type list -default {reset} + -rawresets -type ansi -default "" + -fullcodemerge -type boolean -default 0 -help\ + "experimental" + -overridecodes -type list -default {} @values -min 1 -max 1 text -type string -help\ "String to wrap with ANSI (SGR)" }] - #proc ansiwrap {codes text} { - # return [a {*}$codes]$text[a] - #} - proc ansiwrap2 {args} { - set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] - set codelists [dict get $argd leaders codelist] - set text [dict get $argd values text] - set codes [concat {*}$codelists] ;#flatten - return [a {*}$codes]$text[a] - } proc ansiwrap {args} { if {[llength $args] < 1} { - #minimal args parsing - unhappy path only + #throw to args::parse to get friendly error/usage display punk::args::parse $args withid ::punk::ansi::ansiwrap return } - set text [lindex $args end] - set codelists [lrange $args 0 end-1] + #we know there are no valid codes that start with - + if {[lsearch [lrange $args 0 end-1] -*] == -1} { + #no opts + set text [lindex $args end] + set codelists [lrange $args 0 end-1] + set R [a] ;#plain ansi reset + set rawansi "" + set rawresets "" + set fullmerge 0 + set overrides "" + } else { + set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] + lassign [dict values $argd] leaders opts values received solos + set codelists [dict get $leaders codelist] + set text [dict get $values text] + set rawansi [dict get $opts -rawansi] + set R [a+ {*}[dict get $opts -resetcodes]] + set rawresets [dict get $opts -rawresets] + set fullmerge [dict get $opts -fullcodemerge] + set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]] + } + + #note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence. + #there can be SGR unmergeables (due to enhanced underlines) as well as non SGR codes set codes [concat {*}$codelists] ;#flatten - return [a {*}$codes]$text[a] - } + set base [a+ {*}$codes] + if {$rawansi ne ""} { + set rawcodes [punk::ansi::ta::get_codes_single $rawansi] ;#caller may have supplied as [a+ xxx][a+ yyy] + if {$fullmerge} { + set base [punk::ansi::codetype::sgr_merge [list $base {*}$rawcodes]] + } else { + set base [punk::ansi::codetype::sgr_merge_singles [list $base {*}$rawcodes]] + } + } + if {$rawresets ne ""} { + set rawresetcodes [punk::ansi::ta::get_codes_single $rawresets] + if {$fullmerge} { + set R [punk::ansi::codetype::sgr_merge [list $R {*}$rawresetcodes]] + } else { + set R [punk::ansi::codetype::sgr_merge_singles [list $R {*}$rawresetcodes]] + } + } + set codestack [list] + if {[punk::ansi::ta::detect $text]} { + set emit "" + set parts [punk::ansi::ta::split_codes $text] + foreach {pt code} $parts { + switch -- [llength $codestack] { + 0 { + append emit $base$pt$R + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { + append emit $base$pt$R + set codestack [list] + } else { + #append emit [lindex $o_codestack 0]$pt + if {$fullmerge} { + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + } else { + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + } + } + } + default { + if {$fullmerge} { + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + } else { + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + } + } + } + #parts ends on a pt - last code always empty string + if {$code ne ""} { + set c1c2 [tcl::string::range $code 0 1] + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3] + switch -- $leadernorm { + 7CSI - 8CSI { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #todo - make caching is_sgr method + set dup_posns [lsearch -all -exact $codestack $code] + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set o_gx_state on + } + "B" { + set o_gx_state off + } + } + } + default { + #other ansi codes + } + } + append emit $code + } + } + return $emit$R + } else { + return $base$text$R + } + } + proc ansiwrap_naive {codes text} { + return [a_ {*}$codes]$text[a] + } + + #a silly trick... temporary? probably - todo - tests and work on sgr_merge + sgr_merge_singles before relying on this + #when we use sgr_merge_singles on a 'single' containing a non SGR code e.g [5h (inverse) it puts this code at the end of the list + #furthermore - it carries any SGR codes along with it (Can/should we rely on this behaviour??? probably not) REVIEW + #P% ansistring VIEW $s1 + #- ␛[31m␛[?5h + #P% ansistring VIEW [punk::ansi::codetype::sgr_merge_singles [list $s1 [a+ cyan]]] + #- ␛[36m␛[31m␛[?5h + #P% ansistring VIEW [punk::ansi::codetype::sgr_merge [list $s1 [a+ cyan]]] + #- ␛[36m␛[?5h + #we can use this trick to override background and/or foreground colours using ansiwrap - which uses sgr_merge_singles + #Note - this trick is not composable - e.g ansioverride Red [ansiioverride Green [textblock::periodic]] doesn't work as expected. + proc ansioverride2 {args} { + set text [lindex $args end] + set codes [lrange $args 0 end-1] + ansiwrap {*}$codes -rawansi [punk::ansi::enable_inverse] -rawresets [punk::ansi::disable_inverse] $text + } + proc ansireverse {text} { + ansioverride2 normal reverse $text + } proc get_code_name {code} { #*** !doctools @@ -4491,6 +4633,77 @@ tcl::namespace::eval punk::ansi { return 0 } } + + #e.g has_any_effective $str bg fg + proc has_any_effective {str args} { + set singlecodes [punk::ansi::ta::get_codes_single $str] + set mergeinfo [punk::ansi::codetype::sgr_merge_singles $singlecodes -info 1] + foreach t $args { + switch -- $t { + sgr - unmergeable - othercodes { + if {[dict get $mergeinfo $t] ne ""} { + return 1 + } + } + intensity - italic - underline - underextended - blink - reverse - hide - strike - font - gothic - doubleunderline + - proportional - frame_or_circle - ideogram_underline - ideogram_doubleunderline - ideogram_clear - overline - underlinecolour - superscript - subscript + - nosupersub - fg - bg { + if {[dict get $mergeinfo codestate $t] ne ""} { + return 1 + } + } + bold { + if {[dict get $mergeinfo codestate intensity] eq "1"} { + return 1 + } + } + dim { + if {[dict get $mergeinfo codestate intensity] eq "2"} { + return 1 + } + } + default { + error "punk::ansi::ta::has_any_effective invalid type '$t' specified" + } + } + } + return 0 + } + proc has_all_effective {str args} { + set singlecodes [punk::ansi::ta::get_codes_single $str] + set mergeinfo [punk::ansi::codetype::sgr_merge_singles $singlecodes -info 1] + foreach t $args { + switch -- $t { + sgr - unmergeable - othercodes { + if {[dict get $mergeinfo $t] eq ""} { + return 0 + } + } + intensity - italic - underline - underextended - blink - reverse - hide - strike - font - gothic - doubleunderline + - proportional - frame_or_circle - ideogram_underline - ideogram_doubleunderline - ideogram_clear - overline - underlinecolour - superscript - subscript + - nosupersub - fg - bg { + if {[dict get $mergeinfo codestate $t] eq ""} { + return 0 + } + } + bold { + if {[dict get $mergeinfo codestate intensity] ne "1"} { + return 0 + } + } + dim { + if {[dict get $mergeinfo codestate intensity] ne "2"} { + return 0 + } + } + default { + error "punk::ansi::ta::has_any_effective invalid type '$t' specified" + } + } + } + return 1 + } + proc is_gx {code} { #g0 {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} #g1 {(?:\x1b\)0)(?:(?!\x1b\)B).)*\x1b\)B} @@ -4513,6 +4726,7 @@ tcl::namespace::eval punk::ansi { set codestate_empty [tcl::dict::create] tcl::dict::set codestate_empty rst "" ;#0 (or empty) tcl::dict::set codestate_empty intensity "" ;#1 bold, 2 dim, 22 normal + tcl::dict::set codestate_empty shadowed "" ; tcl::dict::set codestate_empty italic "" ;#3 on 23 off tcl::dict::set codestate_empty underline "" ;#4 on 24 off diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.4.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.4.tm index 95d5c702..e1256fe4 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.4.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.4.tm @@ -3226,7 +3226,36 @@ tcl::namespace::eval punk::args { form1: parse $arglist ?-flag val?... withid $id form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define" + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " @form -form {withid withdef} @leaders -min 1 -max 1 arglist -type list -optional 0 -help\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm index 5532cb80..f2f85349 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -1,23 +1,109 @@ tcl::namespace::eval punk::config { - variable loaded - variable startup ;#include env overrides - variable running + variable configdata [dict create] ;#key on config names. At least default, startup, running + + #variable startup ;#include env overrides + #variable running + variable punk_env_vars variable other_env_vars variable vars namespace export {[a-z]*} + namespace ensemble create + namespace eval punk {namespace export config} + + proc _homedir {} { + if {[info exists ::env(HOME)]} { + set home [file normalize $::env(HOME)] + } else { + #not available on 8.6? ok will error out here. + set home [file tildeexpand ~] + } + return $home + } + + lappend PUNKARGS [list { + @id -id ::punk::config::dir + @cmd -name punk::config::dir -help\ + "Get the path for the default config folder + Config files are in toml format. + + The XDG_CONFIG_HOME env var is the preferred + choice of location. + A folder under the user's home directory, + at .config/punk/shell is chosen if + XDG_CONFIG_HOME is not configured. + " + @leaders -min 0 -max 0 + @opts + -quiet -type none -help\ + "Suppress warning given when the folder does + not yet exist" + @values -min 0 -max 0 + }] + proc dir {args} { + if {"-quiet" in $args} { + set be_quiet [dict exists $received -quiet] + } + + set was_noisy 0 + + set config_home [punk::config::configure running xdg_config_home] + + set config_dir [file join $config_home punk shell] + + if {!$be_quiet && ![file exists $config_dir]} { + set msg "punk::shell data storage folder at $config_dir does not yet exist." + puts stderr $msg + set was_noisy 1 + } + + if {!$be_quiet && $was_noisy} { + puts stderr "punk::config::dir - call with -quiet option to suppress these messages" + } + return $config_dir + + #if {[info exists ::env(XDG_CONFIG_HOME)]} { + # set config_home $::env(XDG_CONFIG_HOME) + #} else { + # set config_home [file join [_homedir] .config] + # if {!$be_quiet} { + # puts stderr "Environment variable XDG_CONFIG_HOME does not exist - consider setting it if $config_home is not a suitable location" + # set was_noisy 1 + # } + #} + #if {!$be_quiet && ![file exists $config_home]} { + # #parent folder for 'punk' config dir doesn't exist + # set msg "configuration location (XDG_CONFIG_HOME or ~/.config) $config_home does not yet exist" + # append msg \n " - please create it and/or set XDG_CONFIG_HOME env var." + # puts stderr $msg + # set was_noisy 1 + #} + #set config_dir [file join $config_home punk shell] + #if {!$be_quiet && ![file exists $config_dir]} { + # set msg "punk::shell data storage folder at $config_dir does not yet exist." + # append msg \n " It will be created if api_context_save is called without specifying an alternate location." + # puts stderr $msg + # set was_noisy 1 + #} + #if {!$be_quiet && $was_noisy} { + # puts stderr "punk::config::dir - call with -quiet option to suppress these messages" + #} + #return [file join $configdir config.toml] + } #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 configdata + + #variable defaults + #variable startup + #variable running variable punk_env_vars variable punk_env_vars_config variable other_env_vars @@ -108,12 +194,14 @@ tcl::namespace::eval punk::config { #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)]} { + #Typical existing/default value for env(APPDATA) on windows is c:\Users\\AppData\Roaming 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)]} { + #Typical existing/default value for env(APPDATA) on windows is c:\Users\\AppData\Local + set default_xdg_data_home $::env(LOCALAPPDATA) set default_xdg_cache_home $::env(LOCALAPPDATA) set default_xdg_state_home $::env(LOCALAPPDATA) } @@ -133,10 +221,10 @@ tcl::namespace::eval punk::config { } } - set defaults [dict create\ + dict set configdata defaults [dict create\ apps $default_apps\ - config ""\ - configset ".punkshell"\ + config "startup"\ + configset "main"\ scriptlib $default_scriptlib\ color_stdout $default_color_stdout\ color_stdout_repl $default_color_stdout_repl\ @@ -160,7 +248,7 @@ tcl::namespace::eval punk::config { posh_themes_path ""\ ] - set startup $defaults + dict set configdata startup [dict get $configdata 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 @@ -219,9 +307,9 @@ tcl::namespace::eval punk::config { lappend final $p } } - tcl::dict::set startup $varname $final + tcl::dict::set configdata startup $varname $final } else { - tcl::dict::set startup $varname $f + tcl::dict::set configdata startup $varname $f } } } @@ -273,29 +361,44 @@ tcl::namespace::eval punk::config { lappend final $p } } - tcl::dict::set startup $varname $final + tcl::dict::set configdata startup $varname $final } else { - tcl::dict::set startup $varname $f + tcl::dict::set configdata startup $varname $f } } } } + set config_home [dict get $configdata startup xdg_config_home] + + if {![file exists $config_home]} { + puts stderr "punk::config::init creating punk shell config dir: [dir]" + puts stderr "(todo)" + } + + set configset [dict get $configdata defaults configset] + set config [dict get $configdata defaults config] + + set startupfile [file join $config_home $configset $config.toml] + if {![file exists $startupfile]} { + puts stderr "punk::config::init creating punk shell config file: $config for configset: $configset" + puts stderr "(todo)" + } #unset -nocomplain vars #todo set running [tcl::dict::create] - set running [tcl::dict::merge $running $startup] + dict set configdata running [tcl::dict::merge $running [dict get $configdata startup]] } - init #todo proc Apply {config} { + variable configdata puts stderr "punk::config::Apply partially implemented" set configname [string map {-config ""} $config] if {$configname in {startup running}} { - upvar ::punk::config::$configname applyconfig + set applyconfig [dict get $configdata $configname] if {[dict exists $applyconfig auto_noexec]} { set auto [dict get $applyconfig auto_noexec] @@ -315,67 +418,128 @@ tcl::namespace::eval punk::config { } return "apply done" } - Apply startup #todo - consider how to divide up settings, categories, 'devices', decks etc proc get_running_global {varname} { - variable running + variable configdata + set running [dict get $configdata 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 + variable configdata + set startup [dict get $configdata 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 + lappend PUNKARGS [list { + @id -id ::punk::config::get + @cmd -name punk::config::get -help\ + "Get configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + whichconfig -type string -choices {config startup-configuration running-configuration} + @values -min 0 -max -1 + globkey -type string -default * -optional 1 -multiple 1 + }] + proc get {args} { + set argd [punk::args::parse $args withid ::punk::config::get] + lassign [dict values $argd] leaders opts values received solos + set whichconfig [dict get $leaders whichconfig] + set globs [dict get $values globkey] ;#list + + variable configdata + switch -- $whichconfig { - config - startup - startup-config - startup-configuration { + config - startup-configuration { + #review 'config' ?? #show *startup* config - different behaviour may be confusing to those used to router startup and running configs - set configdata $startup + set configrecords [dict get $configdata startup] } - running - running-config - running-configuration { - set configdata $running + running-configuration { + set configrecords [dict get $configdata running] } default { error "Unknown config name '$whichconfig' - try startup or running" } } - if {$globfor eq "*"} { - return $configdata + if {"*" in $globs} { + return $configrecords } else { - set keys [dict keys $configdata [string tolower $globfor]] + set keys [list] + foreach g $globs { + lappend keys {*}[dict keys $configrecords [string tolower $g]] ;#review tolower? + } + set filtered [dict create] foreach k $keys { - dict set filtered $k [dict get $configdata $k] + dict set filtered $k [dict get $configrecords $k] } return $filtered } } + lappend PUNKARGS [list { + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ + "Get/set configuration values from a config" + @leaders -min 1 -max 1 + whichconfig -type string -choices {defaults startup-configuration running-configuration} + @values -min 0 -max 2 + key -type string -optional 1 + newvalue -optional 1 + }] 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::parse $args withid ::punk::config::configure] + lassign [dict values $argd] leaders opts values received solos + set whichconfig [dict get $argd leaders whichconfig] + variable configdata + if {"running" ni [dict keys $configdata]} { + init + Apply startup } - set argd [punk::args::get_dict $argdef $args] - return "unimplemented - $argd" + switch -- $whichconfig { + defaults { + set configrecords [dict get $configdata defaults] + } + startup-configuration { + set configrecords [dict get $configdata startup] + } + running-configuration { + set configrecords [dict get $configdata running] + } + } + if {![dict exists $received key]} { + return $configrecords + } + set key [dict get $values key] + if {![dict exists $received newvalue]} { + return [dict get $configrecords $key] + } + error "setting value not implemented" } - proc show {whichconfig {globfor *}} { + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::config::show + @cmd -name punk::config::get -help\ + "Display configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + }\ + {${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ + "@values -min 0 -max -1"\ + {${[punk::args::resolved_def -types values ::punk::config::get]}}\ + ] + proc show {args} { #todo - tables for console - set configdata [punk::config::get $whichconfig $globfor] - return [punk::lib::showdict $configdata] + set configrecords [punk::config::get {*}$args] + return [punk::lib::showdict $configrecords] } @@ -459,27 +623,35 @@ tcl::namespace::eval punk::config { ::tcl::namespace::eval punk::config { #todo - something better - 'previous' rather than reverting to startup proc channelcolors {{onoff {}}} { - variable running - variable startup + variable configdata + #variable running + #variable startup if {![string length $onoff]} { - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + return [list stdout [dict get $configdata running color_stdout] stderr [dict get $configdata 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] + dict set configdata running color_stdout [dict get $startup color_stdout] + dict set configdata running color_stderr [dict get $startup color_stderr] } else { - dict set running color_stdout "" - dict set running color_stderr "" + dict set configdata running color_stdout "" + dict set configdata running color_stderr "" } } - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + return [list stdout [dict get $configdata running color_stdout] stderr [dict get $configdata running color_stderr]] } + } +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::config +} + + package provide punk::config [tcl::namespace::eval punk::config { variable version set version 0.1 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index a3f5d95c..19d9d7e4 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -584,10 +584,10 @@ namespace eval punk::console { channel's response to a query placed on the output channel. Usually this means a write to stdout with a response on stdin. - This function uses a 'chan event' read handler function + This function uses a 'chan event' read handler function ::punk::console::internal::ansi_response_handler_regex to read the input channel character by character to ensure it - doesn't overconsume input. + doesn't overconsume input. It can run cooperatively with the punk::repl stdin reader or other readers if done carefully. @@ -609,7 +609,7 @@ namespace eval punk::console { "dict with keys prefix,response,payload,all" } -help\ "Return format" - + -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" -expected_ms -default 100 -type integer -help\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.tm index 26ed2f2e..8f1ba266 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mod-0.1.tm @@ -33,8 +33,7 @@ namespace eval punk::mod::cli { return $basehelp } proc getraw {appname} { - upvar ::punk::config::running running_config - set app_folders [dict get $running_config apps] + set app_folders [punk::config::configure running apps] #todo search each app folder set bases [::list] set versions [::list] @@ -86,8 +85,7 @@ namespace eval punk::mod::cli { } proc list {{glob *}} { - upvar ::punk::config::running running_config - set apps_folder [dict get $running_config apps] + set apps_folder [punk::config::configure running apps] if {[file exists $apps_folder]} { if {[file exists $apps_folder/$glob]} { #tailcall source $apps_folder/$glob/main.tcl diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index 4eb6526d..b89bc021 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -375,7 +375,9 @@ tcl::namespace::eval punk::ns { #This is because :x (or even just : ) can in theory be the name of a command and we may need to see it (although it is not a good idea) #and a namespace can exist with leading colon - but is even worse - as default Tcl commands will misreport e.g namespace current within namespace eval #The view is taken that a namespace with leading/trailing colons is so error-prone that even introspection is unreliable so we will rule that out. - # + # + #nsprefix is *somewhat* like 'namespace parent' execept that it is string based - ie no requirement for the namespaces to actually exist + # - this is an important usecase even if the handling of 'unwise' command names isn't so critical. proc nsprefix {{nspath ""}} { #normalize the common case of :::: set nspath [string map {:::: ::} $nspath] @@ -394,10 +396,12 @@ tcl::namespace::eval punk::ns { #namespace tail which handles :::cmd ::x:::y ::x:::/y etc in a specific manner for string processing #review - consider making -strict raise an error for unexpected sequences such as :::: or any situation with more than 2 colons together. + #This is only necessary in the context of requirement to browse namespaces with 'unwisely' named commands + #For most purposes 'namespace tail' is fine. proc nstail {nspath args} { #normalize the common case of :::: set nspath [string map {:::: ::} $nspath] - set mapped [string map {:: \u0FFF} $nspath] + set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] set defaults [list -strict 0] @@ -2018,7 +2022,7 @@ tcl::namespace::eval punk::ns { } proc arginfo {args} { lassign [dict values [punk::args::parse $args withid ::punk::ns::arginfo]] leaders opts values received - + set nscaller [uplevel 1 [list ::namespace current]] #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. if {![dict exists $received -scheme]} { @@ -2081,16 +2085,18 @@ tcl::namespace::eval punk::ns { } } else { #namespace as relative to current doesn't seem to exist - #Tcl would also attempt to resolve as global + #Tcl would also attempt to resolve as global - #set numvals [expr {[llength $queryargs]+1}] + #set numvals [expr {[llength $queryargs]+1}] ##puts "THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]] - return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] + if {$nscaller ne "::"} { + return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] + } + + set origin $querycommand + set resolved $querycommand - #set origin $querycommand - #set resolved $querycommand - } } } @@ -2098,7 +2104,7 @@ tcl::namespace::eval punk::ns { #check for a direct match first if {[info commands ::punk::args::id_exists] ne ""} { if {![llength $queryargs]} { - punk::args::update_definitions [list [namespace qualifiers $origin]] + punk::args::update_definitions [list [namespace qualifiers $origin]] if {[punk::args::id_exists $origin]} { return [uplevel 1 [list punk::args::usage {*}$opts $origin]] } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm index a64eef0f..7bf8306e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm @@ -175,13 +175,13 @@ tcl::namespace::eval punk::repl::codethread { set outstack [list] set errstack [list] - upvar ::punk::config::running running_config - if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { + set config_running [::punk::config::configure running] + if {[string length [dict get $config_running color_stdout_repl]] && [interp eval code punk::console::colour]} { lappend outstack [interp eval code [list ::shellfilter::stack add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] } lappend outstack [interp eval code [list ::shellfilter::stack add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] - if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { + if {[string length [dict get $config_running color_stderr_repl]] && [interp eval code punk::console::colour]} { lappend errstack [interp eval code [list ::shellfilter::stack add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] # #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm index 92b214d8..73ea752c 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm @@ -674,6 +674,9 @@ namespace eval shellfilter::chan { #todo - track when in sixel,iterm,kitty graphics data - can be very large method Trackcodes {chunk} { + #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) + #e.g [a+ reset reset] (0;0m vs 0;m) + #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" set buf $o_buffered$chunk set emit "" @@ -686,12 +689,29 @@ namespace eval shellfilter::chan { #process all pt/code pairs except for trailing pt foreach {pt code} [lrange $parts 0 end-1] { #puts "<==[ansistring VIEW -lf 1 $pt]==>" - if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - append emit $o_do_colour$pt$o_do_normal - #append emit $pt - } else { - append emit $pt + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$pt + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt + } } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # append emit $o_do_colour$pt$o_do_normal + # #append emit $pt + #} else { + # append emit $pt + #} set c1c2 [tcl::string::range $code 0 1] set leadernorm [tcl::string::range [tcl::string::map [list\ @@ -732,7 +752,7 @@ namespace eval shellfilter::chan { } - set trailing_pt [lindex $parts end] + set trailing_pt [lindex $parts end] if {[string first \x1b $trailing_pt] >= 0} { #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" #may not be plaintext after all @@ -740,15 +760,32 @@ namespace eval shellfilter::chan { #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" } else { #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] - if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { - append emit $o_do_colour$trailing_pt$o_do_normal - } else { - append emit $trailing_pt + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$trailing_pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$trailing_pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$trailing_pt + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt + } } + #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { + # append emit $o_do_colour$trailing_pt$o_do_normal + #} else { + # append emit $trailing_pt + #} #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext set o_buffered "" } - + } else { #REVIEW - this holding a buffer without emitting as we go is ugly. @@ -759,11 +796,14 @@ namespace eval shellfilter::chan { #puts "-->esc but no detect" #no complete ansi codes - but at least one esc is present - if {[string last \x1b $buf] == [string length $buf]-1} { - #only esc is last char in buf + if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { + #string index in first part of && clause to avoid some unneeded scans of whole string for this test + #we can't use 'string last' - as we need to know only esc is last char in buf #puts ">>trailing-esc<<" set o_buffered \x1b - set emit [string range $buf 0 end-1] + set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal + #set emit [string range $buf 0 end-1] + set buf "" } else { set emit_anyway 0 #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer @@ -774,15 +814,18 @@ namespace eval shellfilter::chan { if {$st_partial_len < 1001} { append o_buffered $chunk set emit "" + set buf "" } else { set emit_anyway 1 - } + set o_buffered "" + } } else { set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code #most opening sequences are 1,2 or 3 chars - review? set open_sequence_detected [punk::ansi::ta::detect_open $buf] if {$possible_code_len > 10 && !$open_sequence_detected} { set emit_anyway 1 + set o_buffered "" } else { #could be composite sequence with params - allow some reasonable max sequence length #todo - configurable max sequence length @@ -790,39 +833,74 @@ namespace eval shellfilter::chan { # - allow some headroom for redundant codes when the caller didn't merge. if {$possible_code_len < 101} { append o_buffered $chunk + set buf "" set emit "" } else { #allow a little more grace if we at least have an opening ansi sequence of any type.. if {$open_sequence_detected && $possible_code_len < 151} { append o_buffered $chunk + set buf "" set emit "" } else { set emit_anyway 1 + set o_buffered "" } } } } if {$emit_anyway} { - #looked ansi-like - but we've given enough length without detecting close.. + #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. + + #looked ansi-like - but we've given enough length without detecting close.. #treat as possible plain text with some esc or unrecognised ansi sequence - if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - set emit $o_do_colour$buf$o_do_normal - } else { - set emit $buf + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # set emit $o_do_colour$buf$o_do_normal + #} else { + # set emit $buf + #} } } - } + } } else { #no esc #puts stdout [a+ yellow]...[a] #test! - if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - set emit $o_do_colour$buf$o_do_normal - } else { - set emit $buf + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } } - #set emit $buf set o_buffered "" } return [dict create emit $emit stacksize [llength $o_codestack]] @@ -849,20 +927,29 @@ namespace eval shellfilter::chan { #puts stdout "" set emit [tcl::encoding::convertto $o_enc $o_buffered] set o_buffered "" - return $emit + return $emit return } method write {transform_handle bytes} { set instring [tcl::encoding::convertfrom $o_enc $bytes] set streaminfo [my Trackcodes $instring] set emit [dict get $streaminfo emit] - if {[dict get $streaminfo stacksize] == 0} { - #no ansi on the stack - we can wrap - #review - set outstring "$o_do_colour$emit$o_do_normal" - } else { - set outstring $emit - } + + #review - wrapping already done in Trackcodes + #if {[dict get $streaminfo stacksize] == 0} { + # #no ansi on the stack - we can wrap + # #review + # set outstring "$o_do_colour$emit$o_do_normal" + #} else { + #} + #if {[llength $o_codestack]} { + # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit + #} else { + # set outstring $emit + #} + + set outstring $emit + #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" return [tcl::encoding::convertto $o_enc $outstring] @@ -2260,7 +2347,7 @@ namespace eval shellfilter { # if {!$is_script} { set experiment 0 - if $experiment { + if {$experiment} { try { set results [exec {*}$commandlist] set exitinfo [list exitcode 0] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm index 35de5e704f3c9f66b7648340e6298f248a15f998..3ae60d426cf6b63988005e9d06eb1aac81a2c04f 100644 GIT binary patch delta 8502 zcmZWu1ymecwxt^h?oM!T+}#PDpuq_eT!TA}BtURdc!Ik-L4vzWu;5OD2X{V?mzjC< zr+cm2d+)RFsjhpg`a3osB80xyU#054cvKpY#hdKwml4;xXFR6R#j z4Tnxzo}ini6yQdU4Flt(2P`M^0Apl~P#cGNxr966dp!6bDD-HGR*YOh0R%nvyuXLw zK1Y#6k%++RVJevFm?%|oGpkj}j6s)g3fAVm_#Fi!YXfQ2VqJG#cNSy~j*aM=g#=Wo zR38Qcr9V!hsGCg$1!>C+w7sUC)DK=e#SL#Ta-~>NU%-^+O3m>=(GnH83phv`gwn*U zW6~^)#w9{p*#uK}@RVg^qe`W33F9RVmGJWpmd-$TA%P#*)U76HP9~UDvvFS-@yS%a zq9Q_gNU-vs`1$5J=Ba-7n3OM5-0uygE6JV~#2^h?_JVHQmRXLjHN)g!(J+0;sTp=5 zzd`utZ{7w!4S8{7>y{TQ&lAUPZlR4NfhnimJB`#16Q5lch_-Otrjsu`wcq{5fD*cU z`E9OcaBfv~X~-HI<*m*635Ybmbm8tWTtiGD(X@W=#H-G(CKNAQr>4F~INeIaHKm!w zQmBw>R+!nNtDvfq%U_Sj^o;;Nu)IuhP+!MBwc9TRt~yrlG7Ao0H8@Yb@GBG_!o7pl zal3M^N$YAwvR%qrCJ^A~dVbrcNS@T3vS-tH_KL;$_%`!$v=g4fzNmVP04Ij&1JW9j zZLG$qB###55+nx;U4x1pz6Xmu5X-fqSv3y2F@J;PMP)EDd8Epdd1w1jbWgy&t3_;I z5^7KgX3gE-{h-iO5um77=LB7>MJ`TE7_jP8`!Ut6OuhuYZqhbrzDmc~HrdpKZM*w@ zJA-j3mKJ`5?{|AGUm_>y19f+Fb-h1;jy^DIGTjn*V{BTOoc-E4zUyuM=-H~o}P{k`v>Tmv)@~=W%Kh-*I9079VK@=?9DKjhMNYQbSKVDp_$^1zUu>TUh8(h0jzH(k^8Au=i{&5#ib+4}OjGZ)i88Y6g9z<> zw~Wch)>j8qJjD?Nlh!rf%G!628l(0!Fev3j6KI*@X$aY$b-An4 zVggEcx6JbkDmCX5%IBNffqO8Trtjc@Z8sM4^CO44s>7|4%&6(9lFS1}pJg$cdw#-- zK(sKaB>i~9Rf zgumzH=vx$IaN?Vi=8r3wUptKUzT@Jj}^bUif@l`g8 z?doxrZLc0~{xA};P0_hGB5(gtU@g^2j7N5SodsF()PXZ*$a5-#t42UDwz5CMPipoS z{BUx4l+Dybr2i@(qO+350RAeJZh9&KA1SfpCyNziU3y1+(sisl9KR#7O19gX9zbZT zdX9TYSQ#FmAf|PRf70zhP>~5G_PMS?oM5bnbxdT9@yI_U&)plGGvW(X=n-b{eP=M; z@i5XahK!o_GxB+Q_3K)RRKM5K8qZpudD>?yA;k8ZLyVE_K-dN^f-1tYm&qibhmr_U zU~P&7{o(`R>?*;?6Dh{m%i<_{l2WcJa#Q2I?}K0+nQFWY$ydYFJ1VT-V+V)pO z;m|)2iFNkaY*b~Tn-eH*{1D=*b$)bjtHQ$2c1RnB-m>@uK}U-MPl@Ta=O|=Q9S>`} zL)8CJf~qGo7^_8F2^RSpdW8_=HFi9h;_J?Xh8he)v0YF+P7rs&IC)>F+qj8(%xm>j0wFk+# zMQMn?Zl0erY;~Hx-6D>mf+rJeKMnV!AYGq*%k(q91t(t!1fy`52hAm&;7A}RWaBC@ zQSRn`X|Z)WRgA=Jhw#be6j^o}%}hAcq1@=keBj&lAo&Bcpo1~E1S+}Zj!7cULoeEg z8MDFG6va-YlFG(A>EUzUx0`&FmUe`$zHc)t6kCVH91^$C=T{WK!2!k)a#%C-Lk}x7 zuNRr+cg`dBXdrGgh8|HJM9YypFM3wM_Tq-{7NUW5<@GII4%0zq_I)2EC+b;8Xzoa; zl#YDok}=BI7fi$P;9g15XcjN0KqE9GV(Yt=!R8SueT@-4#KDzo z-u}SJu~m*|5Ku_wPD!|p$WZ)itBe76)fkBn0U;7IBL{lc`OufgM$LUn5RUBL{nB*5 zE0?J|4@a}{(!-XiI&1FR3Rm_7x+4XDM-RsMcQT+}2bS0{nj|IA-TEkUHbuaq!tUL= zn2@Yh-xc14g>R)WNt|D+J<`33g(V$CKHe#jAHj0S1H3e+$_j^p(%ptur%5#HjGbtY z-^g}q@hUm1cQ@g)K6GYmS-F+S;ZeYQ1`7h9m~)W0!^D}4aLl~0mr>SAw%rGIE$I$ zvwrJEOy{I5nXG(baW*0YqSR_Y5n|grMp4ddtpJHS#9CVl`yHjN^PH zxUD>qfc#<0JYyI2ttbZLP)R2%!}zAsN4~^Fhx>l6Af#Rso;rdh=(now@(&?Foug7s zfxk!BiJ+?m;S$c;AdhUl_oY7Z9g&x%gx;7TFXY;Zsq7Wf7S#L&@R-`GAqzFgYPX~3 zr|QAQh~eoOGaddc*ZV`}Y1^HM!SeWwam&^(%YWiD0crl7cWNWs}3GC7q8IR+)*5=y&YsYxH;AB?xkJ>x~=5dtem+n>PTws4?0_vNmQGsByf#` zX~9svPPts{5LB}O==8GRjL2+KtD)B0`9*us43k zRnKn{(HKsj=R6_9*&Y`go|uyn>bh5*mV|0CF3y;Ch*q_>hvUqnWcFVSa96EH2eGZ8 zWO0=G&iAASclg_-aW9-k=i`084J+hs8nvg;R;7LDK#|XmGXd3gaioV|_F8JosXk|- zqUkaDhD)(qi2b#H6z)rEm9yhnL{|*UUZPO~ zV`kxFPm^Zx6}Um_{NGEUQx%e5r|B}XS5G9FYad(DvE7Vrd zmAKhw0F^-ihRn~sJG=PbdrH6Wq)<^r^1Uz|)-X)x^1W+EPv9A`CGb9DNZPVUV4-Re zUW&W0OB8li(UzfgW>>nJB0*$bhaSO}tlH$foz)~PkzYBOY|aj{M|IN8=%u|7j$k{U zEf>l_5R}sF+pt(8Vk(p|#(8Cq|jf8+rMl8l>-9ut?fm)**6;wBlihk+qkGN^c8=t3RglN z3iw+r@2PqGDd~OFfg8q34!(=Dd&1<~m-;k5;ub6fCm~o{p%FfTyme( z2a87O-8%uX=RxOWv_0qj=LIn#1~*O?Z_^9wH>4o9oc6@=>R*+F^#{Gh$_R`z}5U}J5T)qBJRZ)IQWf1~2hw63 zl3Zc)O)Ms5BI;FQ^tubDkUra0$nz_kudr@n130orhNt`~;jUlhZTDE5-YjaoCLnO{ zn(UDhC}thW;$TK9L1R-;pM*VBX8x2)gk4o-c*Kn6qmJGe0=4oF1{+>q4R7K#BT>V^ zeIsO2ros}ZUYG6{iZH=1$MF4ef9piHl*Ol{IyPnJJWgIWo%w1ubew01rH5F0W-HA_ zrzg6?zv1VE(Hw16MY2*`Cez3F`%_e37koI-_5%q7f1}AoY@qruJ8IZlZU&XI5y-9p(?`isZF zC}8x~6dKcH-^q^p!W{~~x+k%pQ=Z8%=D;u}F)cnXO(UJ48yf{}O)%|Z5ZuvUjY(v# z4B#ukdl(`_x(@A(fA4Bg*~R;UCMZRcW>JWnC>J5ys9GgcQfXBTQ#R;It{pN}V%)!f+C!`8~)=HcNfAwcRw21s&n01m?# z$WM-khsQ%#hxjxz6a8!7Ornx>UkpF{eFqN%!^Q&xBLR#@azg)3&i0Q(?&~c(tjS>d zi7`HOB6?UB!@(P}Vra+}da1fL?i{$t<|@EtcE3T#sdoFe3-|uE)!qCKcAikk3g?sJ zehA#*(8$Qh(1oY1ly_h5Cw6CF_QlOlD6VT)`c4ni_{)?>%z5>~Ue2dIZ?|}EM%tm< zd;$B;DtSTJFR0oR^s~Oewwj@z-q3_1@X9*CM3)9PpXwXNzT$3OexOxrFl!mkL!Z<3 zT+mq9ktlwR85>e27coKEAQ^4CQlKG3lb97f|8!xWO z#a7_(0@h5ZYFYN>rnQ+-#~hXoQ$Yo^{^Lv#&MDPV22PVZr)#O}w7lS4+D5=;8nb~UkwH-MwZYa#qe%>!h z=oVm{7I_p3-hvZ^eAP4~XXIw~;YiUB;VAg#PLkVWW)+za1O(qP89IJ3W>g#V?yMir zX_jpt=^ZGQU3ocK>_TR=qnPxIvC@cWiu{Yji;(u(@uOJy7rqwEZ+-bZld+{lX_{QP zVsBqexGB~Qe<#rqr_MqXev4WMh1-%NF!{8qNjB&x!&R7ib>JjvQK8cgBNeLnJ+H&j zFAop8G}0wmVS8GP6KzVDBbb9Z^|Cculf9Cwrsh`}`=0f_Z6=FHm+-VXE zl+Q{u+$b!h({G4pr!_~@+UYD1`Kg$aiSR)N{xjRrdX9(-vER%kcaQHvRyS|@X9gXh zcLHC0u7$tcp4&NHT_g@JJMynsT~u2%bw$5Z34~-`k^X)v!0HUH#N!X2aFU$}dgS z_|E$NAhH3~j8I-mqRkP$78We`0P4$8RF4>T=qx7}y~C2Kq`f4S*0cTafc8rUu^a5| zcbZ_rC#u`vRF6$m(1kcSJQm8wIi)5R6!r^(vsP>(QCo%OZM~F12;~RM#KQ8Au4}8% zj|s8ppEkot(8qWClB+TQO!@is+{UfSvOvXIy4(8q`7Xg=&#z_H1iE6kTImxIlL(jM z;W77#Z`}c2zsEq1U0?!M^9FIM;F7N#4kzJRROIh!OiPjE7pdm4qo~xkm53}+RRNCn z9=WUWK`zh~0XoIWYUo*{O2C`Cz)+Lp$i?s2uk;KPt$x_`&ItABu{XAI|9pe0moOZ@ zne*N8YH{)*VpbRL<#Zae;m0sW!j5_b$P~Mr;|Gl*9;JEq{eUFR6$?}?PZ9#8x1W6X zTI@_C4Bu^QD#VFdpYUcKlv2hAYoNR7Su%Oa*GMspv$GSy4x~cu^lJB=8)eN>hE2wV zTF3}jQ8rT!&X`t{X~uqfcXFeB7l!}-^V!Tmt-jLXIT<@8-s=w9*Lyk3^s^?)hd6qX zE@?UNRBi9sE@dj4JXlCEWm29y2xbH)qMu!>;h^$x!RyK|Nnz)UOLIi`L8y6U0%?l7 zXJW_l5^e1C-3F$hq}$-pX?FHd)fqM*NZZ{&M!bBJQC+?aLXK>9tX-Hm=$K2lDaPs_ zOh{rP{G3B3`r@!VN_CybAc%#z#Y?G3`gWW;ZOWf)p*$98K0w9ZXv8%#8ocUEufTG} zF|Dw@y>0BaqbK5puy1ioCo2*?aWSt@aJsj*H}%dcF4h`)|9ny;l?`7a*GWELl5nP5 z-R|VgyoX*BwmC0LfA9|yb208}*+aC08Q4K1;@b8D=FuzVo-^v{RFmC!W}hPX9`tg8 zNiW@Z2#ghomWM}dHSJFDsjWuW=?T7H%Nk(zYBstD3OFpEzaMjFs_dco{ZRMHh86$N zntS4!u5?S6cS2t=ZKKk@gfGG`8fObSVCopcly=8~)Bo`AqJ{|bu_j4($!qPh>anPZ zBE!Il0hu2GK`Zf}%&=)77kwziC@$c1jckjBJmJS!GW85)2nxJew39>k8xE&F-` z7sMAQh1-BJERBa?G~XV$X+~LFZ8a?m9e@3{D)ZC$d+MAQX#`mYzfvUa79pKH8a&)5 zwa$BQp2H6C`gDLaplHpRrNb zo}Y$|D0!>ivH514fw9Uxzu0x3IN$6emCc!5;aFt?!fH-`xO(>_BrL*Q|HZh!2eiPv z{-)FGAY3+uw0b?_G8=gmk_$EIB|%>bblPO|dhc@cvhQGZH@eR+B$O}hRC(cK<$BHU z+C|9s91cOynAm6qDU^&%=%?`nc5~FfPpB z{oUi!LqN6gE82fOJOuEHqQEZ+fYmAvV7kZ^y!RKB24aiZK$1XvaX1*3>`_nzRs_(1 zyb=f~0~jxf0LxK6iR@(HSHsF4WS5)(Xjd}h+G@wiw2{@`l1vG2Oz;3)xa(fLIn4a$m_Sa%P-45ScRKTp844n0s^a2>@HUr53>^+5`wZ~B$IB*kqvKaP~f&B~~En+}R zuNep*80(V-ls!-Yw>}+E<0GpCzcG9YTYHK<%|II<17H6w*$!BMQ;eRXBi;x=i5JV0 zW77*4^*@UUG5%vf2E@HNo(xxmWZ;f}$?|_m6#vuS|0lsCvN!qbY)SsncK`oQAIRt- z0ZNC+z^5ia<)}D-Hp~W2v3!IQ0CZRw3~T!bA^^T_C;-L?1RU+~B>9Z+gD)JPV3<1w z5H^AeV2_f4Ke{|ha!)JqVH5)D0xCuWz`wnL$}t(hKOPnMFa`mq_&-u_uyg3sY=?0k z@O;=GhyWORBRwT^&BI3j=edYR{@ZfzjmiAazmosC<@o137`&Lr3xh-SfA2v4nc{y+ i&wr(GO!zAW-T$vdDvIz3fBBRj-x&}XnBb(p*#7|@cE9id delta 6274 zcmZXYbyyW$+qc<6$7TZpg2HA?vq4(vl15TMLOP{EK$Gp52%@w|m!c?L z((rO~`|v&A`_3H49M^gNu359z95er{$VT*-T=a@)^r~2Nd2)3A>V&E}$|?-#AmM9W zZcVdn4iYr9JTM(@h&pwc;jg{$*wZ3XW*;Rqaa-SHCvU*n+_0-^>e=88;0>6PHle8Q zp0uVPVO4n99DI4`1%EfcLuWTlIa~kSMt%97$I*@u?1^Bq{FbtEyxe%(dxRS8L8nH_ z{vskVmfKMi_d!w?zetY>yEZk>5h)+Wh$0iqd}o4+3My0R2Z|f_J3j{QA#FJ5KC7@hzN1OSbOy0)Z z*cc*OT>GjEc;>aDLUIXV%VxCGW*K^!j$Dvz}CvSMhH@O)CFkjh_|8Mh2>pCo-M_7e%#g24^z*R5ot*rR_6Py9GCN4hrsx!tmKImSEqMhsyP+GW3B07#`>Tq+W6uzx4Ip}bX?K6PU0Qwl3Y?u z&G3L{m7QM3v`4=ic|Rxon$TI#m*>3O5XPZkL}LD2Fu@aLll3SEe(w{^-a+$8QmvYU ztCJGuiRQ+!Uy^8MOX|8!sBr!Faz1QJ>|DR3Z2oL0#JTcC6=d+!|6h3;m%*S<_g7vPneSZ?9ukBvbomINzFStIIJfD?3&v2ooQ=d{M<>{^eP~CL zy^k2el-uzNv;%cd#4jWW)(S>x_jaBxJJ6l`Z{MH#DJ{M?M0%N)d(=x&4$+>ko=89M zLq!>#_A3V4A&XppozaNBZ41(z6=`d3uAhDB7NWXtWf+z-rhc+R?z>(v+*t99GH?~c zs!5>)Ww<(1GfH+VJ^b4X$qx-)OwrUrohKJ78(%n*e)<=z?VimY8~QoSQ@ho=zS2ny z#NH_#4B3bKj`Mm}#GZUrsx=hr+d6eRz3?{pxqZ$sq0{tf99HE*CNJ%Q%QKT#Qbogx zt}$*$lv6$=ypHZE{Du+<>yyBCdt<%cS9&B6iRuuz9Tc&@vmD;+Z*6&B!LZ$slH>U6 zW4+F>RF)L4LzzB|ET{%#2~w}4#|BEVE7jtpXqb9&TKCDv7WVmwz(EtC?(2=$#9 zMoG|~rMVv|o(#RaY+^ijkV}K@VcwpsK@j(xvLGL)0H%?Mra*1ElcxV`=qvPaOlLo_)^N`CRH^Sh z*|tPrJ&P1s5t5-Y$s8Giw)S}M%rMv%U~RRs`McmPiO=TZ)6Y+x%2J-be=rHnj^l#K z&^$`2*+zZ)PJ@Z%wl5PsG*vupgi>xp(iWjF1PIruF$VOR@g#5t)uM%!WlL)Jj2wm# zF)jBJ%1L<)8J(~jnWW(&SWFA!4xgK_l+)3Bhgq2U4>!EGA~p6imyAP@t21;EY(%{0 zz?kxJ2y<*SO`ZeQHs%gAejE4mOt;cbTRUwz3eDoER#|z3)2h2ay`DH9w{NqFBRJr@Q?8Mx6mR?%%c{mk>0wQ8N?ReJAa#?1&Rwt zk0RP-J#Fl55xH*uan8=$5mw^zVhcu3V7k6Kds}6BejU647vA!x)Nq=} za4kbV>v!1e)*-8yM>LFgdA`0PWpO;k9q0Jr=MrgJSDN|uMET7o1{(80TEP-j)E&6p_6$)mv8EyTlD z)}luUN%6S0b-_+Eao5&KwQoC9_scCiy*xXG6l=9TFMgs4;qNwukP~4*1uGnKV z_;H%)K2DH?Eo3>U8NjTC&QD;_eL!p#AbEgxkZVg5U>JnV){aRc!Cmgbi69b?3eGa1 zs2rzsV!msoEwm0vy|s*D)!o+aJFS#fQ6?&Z6l6`nT4&dUyAQ;D`9p$!PPu)Dua)<0 z#cUIlIe=_(P&>GDHi;ue(O_f!L|4^&Bvj*=U4grRbDQ(m^pubMMztKgSU8M zN*eXNJR2I+xr681bFO2^HiVVCQ2s1VY@BjbYDG17mLUd0&XXZt{W2cEZ=`Vf-|=Gf+0UHnMMs;D zUVxk}bq}sVok)XG5(6)ui-Ho|%jGNddD1QiMg)>go<;n8*ys}P=i+3B6j>HIc-+r$tJc)|wdLK4dfg7Ri8Y_m0N8{NuSE&s zu&pa<4;G2%&}20Cg&x;v9RrsRK}zC6n3;#4PiQlWx`4%^Y+6<8wSBOn0tVdvoCH#f z*}6qFxV^;iZD~F_;>-6dbB^>7d*@h1*kmM?#KSPJXV7}gWP=5xiuf{V;C{LDk-Uu@ zPDm&QE5+*-i?IyMVaNJxg}E4IA6vVtiO08GXR+>nnZNXFWsOQu}v zPjFc!b{_u=h3s5rTCL$+jPMnzOF8hS=-}+93)+1aHP3Sa%md%CSJ6{-UKjcIq>u5Z zv3CT-X6d^GLgr-D+2lQNMZ9Q=fsB1Rf`U=i&ToL6)s&OPYC z9m(czK6-iAue4!{5nha+@5FGFz7noixxkyns}vZhYedJFv#<(ia;y}>v2xjtMf z+)XZja+wWRTplP6e{;uRGjaaM_I#wtbF;kZ<&YwV8YeLeeKUm*N(^#AN0ur1M&We% z3y2Z@Xx>>W8Ds*#88iM_)y1Et&5jRe=fQVoHecTA>tL3BOGKLYTXe&>j@jHfKls!y z>4j0lH&oKrl!=wW*oL_S)?NCX4fv=i2r!MHh6QcKT>><=w;#HHbVjUCJ~&+%jhMCT87C9VUt`>tPCW~J|2aZXCf*U2N}Y@pmklo?PWJS$4Q#}& z>Egr@)Uf$%A=%IH*2C}Nc!B_pnEZ^pMSGKS30$a@b&a? zCp(9g*_|kQB!vXvg>S3FAofO`gzUPBA4!zxqj1Z*?KNq&)p+6NYcw+t5Fmc~3Pot_}5h#!(LYI@B|SWXkH1apF|lK3X`}+H z$6LMz*b}@!X34T0&bD(5wi>#%ySN0SY`a+=_W0;<=Xb)DJE#}6=?az56Z*Q-CP>1L zY>kzCdD3g&-!Bb`N`GN%go#C}$EU*N9_mnBZQ~}DK0u|&R~`P=Vjw=~S$UQ@r$Oz; z^e+s2N?1$2iyvXUkWq}9_Xf*j)^CA7!r##0?lFzvq}K{3;_DYPJdN-T?ajXjLH+(p zHPc1jQli~+(>=gnW?Jv}{7|-rY{t?#h~BT7pf|Ni|{WXkrTUXvB}A zw_=k_7S^H(s!hdDoq4PhMmTLxUTJ`5R9)r2GMno56hw;VW20474ATO4wNE$~=$P97 z(4zLjoILP_d0q^4#=}={74OChmNA(crs_z#)= zWbY273wv&k*Mci~s4F0LU1eH5AyowySGP~cmL@pIp8E-`hr{_$kmP<`^~@v%Jn zm%TbLXI)PF`ma*D`C~l8fzv|9baKgyfiA6CSQ{b=ksIKK+C5m)pOtq3ANWzKaXE1B zaOL~kpPmuxN$@7Wunmpu!2Zg~7`Qu`6gDvIx@N-g%7+z!wpWdPFotPqaaa&Qp`d)34Z&ivc3)ojA-+kzygbADdrXm?!r>nJ`@X zO)5H)3MbKGQkLl}+wI6IYHgH)_SQ#_yEL{TgiC+4^7kZiKggJI#@0bfDAw?IBXH?b zW>XCEoyQ6tijPW^)-UnKodO{v4ka9?3QlKb_wHt+y#?zN^OKY$yx;@anLJUv@EdBe&N{0G(e z2CLnC2(CDu(8_MLhOC6U?0T!^Gi#E8BeND5uXpQ4#X_gEiwPxACNWaXouq%f}Y?Zx;w}+!G^W{pc>|_>&AC`Wk=F%j@Pu#8bTiwQE9*n~B zso`9oE}?9>{GC_zYp9V0)-S?jmh>tI)^Ahw%I?XmSM%zUQAfaQ)Nv)-ENhPG1N7LQ z&4X5D?D*Bk``JDTzxee8&2_%h(rWSX8GV~rE+`sany|xW>Q0Zl{~bn?%>h8Sa4h5p z4aIL2a0ODi#u=0KpF#sZEl+U8C28KBQ<6Q)5fBcKvA9=8WK$Jiz}I8YlvhWKo@ibK z{zygKGI`bvB@sqVD&6xjF$`W_S9CeGt2Onqex9@RoJXu2*MAk-NIaW;{@DqFFBv8vw`M~h<>B^MVrvGI!pU9)2$ z(h)Q?GRBBJMvvEs%nJY;yQuh(Ph~OLix7-1p zth(h{Bu{OIe#SMN5L0_fjs>ssw?8d#Hc)8V?anT4e#+u94qdqOW8rMzsryjR7A2-5 zLGi0ki4w)FGacrPjD2gz2uE2HWp)>5VUyKLNnM+Qd(v73qT zIray>@k(bJAp{yH3&8!0bR!bQmTLe(=`qYV1tW~U|?M%5~yMRFGX=ZH7qF-=+&}s4t~(7 z$sed;y=fG0<^!yFZ!lQ}3VO5=flJMI0J{e_TCPPL@PBxNrK-5#doU_62I}{40GT_u9xsm*OrVE_s2Jq0Dk_`uQuDWhZ3kYfdEipmV z3p{Y(6B5|{SFwNA2RwDI(*|csaPBh_z<73rqM(8+BWO2>1cLuTG4Qji#1#^N3`1}L zsdudkhls%wcT(_T5DP3H5(Rqy)$GHjfQkOU9d1G(bOZ^U{EO}*Hb92Kb+Y0vdp(@n zC>-(#6d#iYqdf$#&A0~%SX@N_nZL66fUnVYJM*|cKxlkjZg}B=!{g6@y#Jv5^=--% zaNvo_RR=eiIUxd^SYDT}zmkFTSF`5+iUdq;{wf7v%l>Z(1F0wZ0WGH+EOdi`tdj&_ z)g&DF<$R;vM@YbesjG3O;1GIHZORW&^STM)iNqk|^wla+H%i`<2+X-sV<9(+XyySR v6n=x5*;wG#IPUesa%SK_M&$n&QF{}St3JlW`sV{vygK<<(9m3C{-OT?q*SmI diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm index 8c778061..9f4e75ee 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -4301,7 +4301,7 @@ tcl::namespace::eval textblock { if {[dict get $opts -frame]} { #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table [a]" [$t print]] } else { set output [$t print] } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.6.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.6.tm index a562545a..7abbaeae 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.6.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.6.tm @@ -265,7 +265,7 @@ namespace eval tomlish { #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey #DDDD switch -exact -- [lindex $sub 0] { - STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - TABLE - ARRAY - ITABLE { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - TIME-TZ - TABLE - ARRAY - ITABLE { lappend values $sub lappend value_posns $posn } @@ -311,18 +311,16 @@ namespace eval tomlish { lassign [lindex $values 0] type_d1 value_d1 lassign [lindex $values 1] type_d2 value_d2 #DDDD - if {$type_d1 ne "DATE-LOCAL" || $type_d2 ni {DATETIME TIME-LOCAL}} { + if {$type_d1 ne "DATE-LOCAL" || $type_d2 ni {TIME-TZ TIME-LOCAL}} { #we reuse DATETIME tag for standalone time with tz offset (or zZ) error "tomlish KEY in 2 parts does not appear to be datetime '$keyval_element'" } if {$type_d2 eq "TIME-LOCAL"} { set type DATETIME-LOCAL - } else { - #extra check that 2nd part is actually a time - if {![tomlish::utils::is_timepart $value_d2]} { - error "tomlish KEY in 2 parts does not appear to be datetime. (part 2 not a time value) '$keyval_element'" - } + } elseif {$type_d2 eq "TIME-TZ"} { set type DATETIME + } else { + error "tomlish KEY in 2 parts does not appear to be datetime. (part 2 not a time value) '$keyval_element'" } set value "${value_d1}T${value_d2}" } @@ -332,6 +330,10 @@ namespace eval tomlish { } set sub_tablenames_info [dict create] switch -exact -- $type { + TIME-TZ { + #This is only valid in tomlish following a DATE-LOCAL + error "tomlish type TIME-TZ was not preceeded by DATE-LOCAL in keyval '$keyval_element'" + } INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL { #DDDD #simple (non-container, no-substitution) datatype @@ -383,8 +385,8 @@ namespace eval tomlish { } - proc to_dict {tomlish} { - tomlish::dict::from_tomlish $tomlish + proc to_dict {tomlish {returnextra 0}} { + tomlish::dict::from_tomlish $tomlish $returnextra } @@ -437,7 +439,8 @@ namespace eval tomlish { #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW # #TODO - set tomlpart "x=\"\"\"\\\n" + #set tomlpart "x=\"\"\"\\\n" ;#no need for continuation + set tomlpart "x=\"\"\"\n" append tomlpart [tomlish::utils::rawstring_to_MultiBstring_with_escaped_controls $val] append tomlpart "\"\"\"" set tomlish [tomlish::from_toml $tomlpart] @@ -519,6 +522,10 @@ namespace eval tomlish { lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} } else { if {$vinfo ne ""} { + if {![tomlish::utils::string_is_dict $vinfo]} { + #e.g tomlish::dict::from_tomlish was called with return_extra 1 + return -code error -errorcode {TOMLISH SYNTAX INVALIDDICT} "tomlish::_from_dictval Supplied dict is not a valid format for converting to tomlish" ;#review + } #set result [list DOTTEDKEY [list [list KEY $k]] = ] #set records [list ITABLE] @@ -645,6 +652,10 @@ namespace eval tomlish { } } else { if {$vinfo ne ""} { + if {![tomlish::utils::string_is_dict $vinfo]} { + #e.g tomlish::dict::from_tomlish was called with return_extra 1 + return -code error -errorcode {TOMLISH SYNTAX INVALIDDICT} "tomlish::_from_dictval Supplied dict is not a valid format for converting to tomlish" ;#review + } set lastidx [expr {[dict size $vinfo] -1}] set dictidx 0 set sub [list] @@ -1522,30 +1533,28 @@ namespace eval tomlish { #DDDD if {[::tomlish::utils::is_float $tok]} { set tag FLOAT - } elseif {[::tomlish::utils::is_localtime $tok]} { + } elseif {[::tomlish::utils::is_time-local $tok]} { set tag TIME-LOCAL } elseif {[::tomlish::utils::is_timepart $tok]} { - #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a previous localdate - set tag DATETIME ;#?? review standalone time with tz - no specific tag - only allowed as followup value from DATETIME-LOCAL - } elseif {[::tomlish::utils::is_datepart $tok]} { + ###################################### + #Note we must allow lone timepart here (not just is_time-local which doesn't allow tz offsets) in case it followed a previous localdate + #set tag DATETIME ;#PLACEHOLDER tag - review standalone time with tz - no specific tag - only allowed as followup value from DATE-LOCAL + set tag TIME-TZ + #This will become a DATETIME or a DATETIME-LOCAL (or will error) + ###################################### + } elseif {[::tomlish::utils::is_date-local $tok]} { set tag DATE-LOCAL - } elseif {[::tomlish::utils::is_datetime $tok]} { + } elseif {[::tomlish::utils::is_date_or_time_or_datetime $tok]} { #not just a date or just a time #could be either local or have tz offset #DDDD JJJ set norm [string map {" " T} $tok];#prob unneeded - we won't get here if there was a space - would arrive as 2 separate tokens review. lassign [split $norm T] dp tp - if {[::tomlish::utils::is_localtime $tp]} { + if {[::tomlish::utils::is_time-local $tp]} { set tag DATETIME-LOCAL } else { set tag DATETIME } - } elseif {[::tomlish::utils::is_datetime X$tok] || [::tomlish::utils::is_timepart X$tok]} { - # obsolete - #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a previous localdate - #e.g x= 2025-01-01 02:34Z - #The dict::from_tomlish validation will catch an invalid standaline timepart, or combine with leading date if applicable. - set tag DATETIME } else { error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" } @@ -1662,6 +1671,433 @@ namespace eval tomlish { } + #return TOMLISH { value} from new and existing typeval dicts of form {type value value} but + # some such as MULTISTRING can be of form { ...} + # + #Don't validate here - validate in tomlish::dict::path::setleaf + proc _update_tomlish_typeval_convert_to_new_from_existing {new existing} { + #we deliberately don't support container types that can contain comments e.g ARRAY, ITABLE, DOTTEDKEY + #This is also not for higher level constructs such as TABLE, TABLEARRAY + if {!([tomlish::dict::is_typeval $target] && [tomlish::dict_is_typveval $source])} { + error "_update_tomlish_typeval_convert_to: target and source must be of form {type value are contained in the table + foreach tr $tablechildren { + set tr_type [lindex $tr 0] + switch -- $tr_type { + NEWLINE - WS - COMMENT { + lappend updated_tablechildren $tr + } + DOTTEDKEY { + #review + #UUU + set dktomlish [list TOMLISH $tr] + set dkdict [::tomlish::to_dict $dktomlish] + set newdktomlish [update_tomlish_from_dict $dktomlish $subd] + set newrecords [lrange $newdktomlish 1 end];#strip TOMLISH + lappend updated_tablechildren {*}$newrecords + } + default { + error "update_tomlish_from_dict: unexpected table record type $tr_type" + } + } + } + + #todo - add leaves from subd that weren't in the tablechildren list + #ordering? + + lappend output_tomlish [list {*}[lrange $tomlish_record 0 1] {*}$updated_tablechildren] + } + DOTTEDKEY { + #We don't have to check toml table rules regarding created/defined here as dict::from_tomlish has already ensured correctness + #UUU + set dkinfo [tomlish::get_dottedkey_info $tomlish_record] ;#e.g keys {j { k} l} keys_raw {j {' k'} l} + set keys [dict get $dkinfo keys] + set dk_refpath [lmap k $keys {string cat @@ $k}] + + set kvinfo [tomlish::_get_keyval_value $tomlish_record] + set existing_typeval [dict get $kvinfo result] + if {[tomlish::dict::is_typeval $existing_typeval] && [dict get $existing_typeval type] ne "ARRAY"} { + #leaf in supplied tomlish - source dict must also be leaf (invalid to rewrite a branch) + #e.g + #DOTTEDKEY {{KEY j} DOTSEP {SQKEY { k}} DOTSEP {KEY l}} = {INT 0} {WS { }} {COMMENT comment} {NEWLINE lf} + #existing_typeval: {type INT value 0} + #e.g + #DOTTEDKEY {{KEY j} DOTSEP {SQKEY { k}} DOTSEP {KEY l}} = {MULTISTRING {WS { }} {STRINGPART x} {WS { }}} {WS { }} {COMMENT comment} {NEWLINE lf} + #existing_typeval: {type MULTISTRING value { x }} + + #see if source dict has a simple typeval to set + set new_typeval [tomlish::dict::path::get $d $dk_refpath] + if {![tomlish::dict::is_typeval $new_typeval]} { + error "update_tomlish_from_dict - update dictionary has non-leaf data at path $dk_refpath - cannot set" + } + #update if type matches. Todo - flag -allowtypechange ? + set e_type [dict get $existing_typeval type] + set n_type [dict get $new_typeval type] + if {$e_type ne $n_type} { + error "update_tomlish_from_dict - cannot change type $e_type to $n_type at path $dk_refpath" + } + #-start 3 to begin search after = + set valindex [lsearch -start 3 -index 0 $tomlish_record $e_type] + if {$valindex == -1} { + error "update_tomlish_from_dict - unexpected error - failed to find $e_type in record $tomlish_record" + } + set rawval [dict get $new_typeval value] + switch -- $e_type { + MULTISTRING { + #UUU + set newval [tomlish::utils::rawstring_to_MultiBstring_with_escaped_controls $rawval] + set toml "" + append toml "x=\"\"\"" \n + append toml "$newval\"\"\"" \n + set tomlish [lrange [tomlish::from_toml $toml] 1 end] ;#remove TOMLISH keyword + #assert tomlish is a list with a single element + #e.g {DOTTEDKEY {{KEY x}} = {MULTISTRING {NEWLINE lf} {STRINGPART aaa}} {NEWLINE lf}} + set dklist [lindex $tomlish 0] + set msrecord [lindex $dklist 3] + #e.g + #MULTISTRING {NEWLINE lf} {STRINGPART aaa} + + #error "update_tomlish_from_dict MULTISTRING update unimplemented. Todo" + lset tomlish_record $valindex $msrecord + } + MULTILITERAL { + set toml "" + append toml "x='''" \n + append toml "$rawval'''" \n + set tomlish [lrange [tomlish::from_toml $toml] 1 end] ;#remove TOMLISH keyword + set dklist [lindex $tomlish 0] + set msrecord [lindex $dklist 3] + lset tomlish_record $valindex $msrecord + } + default { + switch -- $e_type { + STRING { + #review + set newval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $rawval] + } + default { + set newval $rawval + } + } + lset tomlish_record $valindex [list $e_type $newval] + } + } + + } elseif {[tomlish::dict::is_typeval $existing_typeval] && [dict get $existing_typeval type] eq "ARRAY"} { + #e.g + #DOTTEDKEY {{KEY a}} = {ARRAY {INT 1} SEP {INT 2} SEP {INT 3}} + #DOTTEDKEY {{KEY a} {WS { }}} = {WS { }} {ARRAY {INT 1} {WS { }} SEP {INT 2} {WS { }} SEP {INT 3}} {WS { }} + #existing_typeval: {type ARRAY value {{type INT value 1} {type INT value 2} {type INT value 3}}} + + #= is always at index 2 (any preceding whitespace is attached to keylist) + set valindex [lsearch -start 3 -index 0 $tomlish_record ARRAY] + if {$valindex == -1} { + error "update_tomlish_from_dict - unexpected error - failed to find ARRAY in record $tomlish_record" + } + + set existing_arraytomlish [lindex $tomlish_record $valindex] + puts "update_tomlish_from_dict: existing_arraytomlish: $existing_arraytomlish" + set subd [tomlish::dict::path::get $d $dk_refpath] + #set existing_items [tomlish::dict::from_tomlish $tomlish_record] ;#utilise fragment processing of dict::from_tomlish - to produce a LIST + #we expect the subdict structure to be something like: + # {type ARRAY value {{type INT value 1} {type INT value 2}}} + # or with untagged subdicts (ITABLE in tomlish) + # {type ARRAY value {{x {type INT value 1}} {type INT value 2}}} + + + #we can only have one ARRAY record - so we can use lset + set newsubrecord_itable [update_tomlish_from_dict [list $existing_arraytomlish] $subd] + lset tomlish_record $valindex [lindex $newsubrecord_itable 0] ;#passed in a single element tomlish list - expect only one back + + } elseif {[tomlish::dict::is_typeval_dict $existing_typeval]} { + #Not actually a {type value } structure. + #sub dict (ITABLE) + #e.g + #DOTTEDKEY {{KEY j} DOTSEP {SQKEY { k}} DOTSEP {KEY l}} = {ITABLE {DOTTEDKEY {{KEY q}} = {INT 1}}} {WS { }} {COMMENT comment} {NEWLINE lf} + #DOTTEDKEY {{KEY x} {WS { }}} = {WS { }} {ITABLE {WS { }} {DOTTEDKEY {{KEY j}} = {INT 1} {WS { }} SEP} {WS { }} {DOTTEDKEY {{KEY k} {WS { }}} = {WS { }} {INT 333}}} {WS { }} {COMMENT {test }} + #existingvaldata: {q {type INT value 1}} + set subd [tomlish::dict::path::get $d $dk_refpath] + #= is always at index 2 (any preceding whitespace is attached to keylist) + set valindex [lsearch -start 3 -index 0 $tomlish_record ITABLE] + if {$valindex == -1} { + error "update_tomlish_from_dict - unexpected error - failed to find ITABLE in record $tomlish_record" + } + #we can only have one ITABLE record - so we can use lset + + set itablerecord [lindex $tomlish_record $valindex] + puts "update_tomlish_from_dict: existing_itabletomlish: $itablerecord" + set newsubrecord_itable [update_tomlish_from_dict [list $itablerecord] $subd] + lset tomlish_record $valindex [lindex $newsubrecord_itable 0] + } else { + #unreachable? - dict::from_tomlish didn't object. + error "update_tomlish_from_dict: Unexpected data in DOTTEDKEY record: $existing_typeval" + } + lappend output_tomlish $tomlish_record + } + ARRAY { + #UUU + #fragment recursion + puts "update_tomlish_from_dict: process ARRAY fragment" + puts "tomlish:\n$tomlish" + puts "updatedict:\n$d" + set source_d_elements [tomlish::dict::path::get $d {[]}] + + set updated_arraychildren [list] + set arrayrecord $tomlish_record + set arraychildren [lrange $arrayrecord 1 end] ;#includes WS, SEP, NEWLINE, COMMENT + set arridx 0 + set childidx 0 + foreach arrchild $arraychildren { + set arrchild_type [lindex $arrchild 0] + switch -- $arrchild_type { + SEP { + #we don't check for proper SEP interspersal here, presuming well-formed tomlish - review + lappend updated_arraychildren $arrchild + } + NEWLINE - WS - COMMENT { + lappend updated_arraychildren $arrchild + } + default { + #updatables + #review - type changes from existing value?? + set sourcedata [lindex $source_d_elements $arridx] + switch -- $arrchild_type { + STRING - LITERAL - FLOAT - INT - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL { + #basic types - no recursion needed + #REVIEW - change of type? flag to allow/disallow? + if {![tomlish::dict::is_typeval $sourcedata]} { + error "update_tomlish_from_dict - update dictionary has non-leaf data at path \[$arridx\] - cannot set" + } + set newval [dict get $sourcedata value] + set newtype [dict get $sourcedata type] + if {$newtype eq "STRING"} { + set newval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $newval] + } + lappend updated_arraychildren [list $newtype $newval] + } + MULTISTRING { + #no need to recurse + puts stderr "multistring within array update - unimplemented" + } + MULTILITERAL { + #no need to recurse + puts stderr "multiliteral within array update - unimplemented" + } + ITABLE - ARRAY { + #recurse + puts stderr "update $tomlish_type within array" + set nextd [tomlish::dict::path::get $d $arridx] + set subrecord_tomlish [list $arrchild] + set newsubrecord_tomlish [update_tomlish_from_dict $subrecord_tomlish $nextd] + lappend updated_arraychildren {*}$newsubrecord_tomlish + } + default { + error "update_tomlish_from_dict: unexpected array child record type $arrchild_type" + } + } + incr arridx ;#only increment array index for updatables + } + } + } + + lappend output_tomlish [list ARRAY {*}$updated_arraychildren] + } + ITABLE { + #fragment recursion target + #ITABLE {DOTTEDKEY {{KEY j}} = {INT 1}} + #ITABLE {WS { }} {DOTTEDKEY {{KEY j}} = {INT 1} {WS { }} SEP} {WS { }} {DOTTEDKEY {{KEY k} {WS { }}} = {WS { }} {INT 333}} + #ITABLE {NEWLINE lf} {DOTTEDKEY {{KEY j} {WS { }}} = {WS { }} {INT 1} SEP} {WS { }} {COMMENT test} {NEWLINE lf} {WS { }} {DOTTEDKEY {{KEY k}} = {WS { }} {INT 2} {NEWLINE lf}} + puts "update_tomlish_from_dict: process ITABLE fragment" + puts "tomlish:\n$tomlish" + puts "updatedict:\n$d" + set updated_itablechildren [list] + set itablechildren [lrange $tomlish_record 1 end] ;#includes WS, NEWLINE, COMMENT (possibly SEP - though it may be attached to DOTTEDKEY record REVIEW) + #we only expect DOTTEDKEY records for data items within ITABLE + foreach itablechild $tomlish_record { + set itablechild_type [lindex $itablechild 0] + switch -- $itablechild_type { + SEP { + #REVIEW + #we don't necessarily expect a SEP *directly* within ITABLE records as currently when they're created by tomlish::from_toml + #it attaches them (along with intervening WS, COMMENTs) to each DOTTEDKEY record + #This feels somewhat misaligned with ARRAY - where we have no choice but to have SEP, and COMMENTs independent of the array elements. + #Attaching COMMENTs, SEP to the previous DOTTEDKEY has some merit - but perhaps consistency with ARRAY would be preferable. + #This may change - but in any case it should probably be valid/handled gracefully either way. + lappend updated_itablechildren $itablechild + } + COMMENT - WS - NEWLINE { + lappend updated_itablechildren $itablechild + } + DOTTEDKEY { + puts stderr "update dottedkey in itable: tomlish:[list $itablechild] d:$d" + set updatedtomlish [update_tomlish_from_dict [list $itablechild] $d] + set newrecord [lindex $updatedtomlish 0] + lappend updated_itablechildren $newrecord + } + } + } + + lappend output_tomlish [list ITABLE {*}$updated_itablechildren] + } + default { + error "update_tomlish_from_dict: Unexpected toplevel type $tomlish_type record: $tomlish_record" + } + } + } + return $output_tomlish + } + #*** !doctools #[list_end] [comment {--- end definitions namespace tomlish ---}] @@ -1713,7 +2149,7 @@ namespace eval tomlish::build { } proc DATETIME {str} { - if {[::tomlish::utils::is_datetime $str]} { + if {[::tomlish::utils::is_date_or_time_or_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]" @@ -2052,6 +2488,103 @@ namespace eval tomlish::utils { } #------------------------------------------------------------------------------ + #subset of jq syntax for get/set operations on dicts + # no filters or multiple targets + # meant for 'leaf' queries + proc jq_to_path {jq} { + set jq [string trim $jq] ;#don't tokenize any leading/trailing whitespace + set path [list] + set in_arr 0 + set in_dq 0 + set tok "" + set bsl 0 + foreach c [split $jq ""] { + if {$c eq "\\"} { + if {$bsl} { + set bsl 0 + set c "\\" + } else { + set bsl 1 + continue + } + } else { + if {$bsl} { + set c "\\$c" + set bsl 0 + } + } + if {$in_arr} { + switch -- $c { + {]} { + set in_arr 0 + lappend path $tok + set tok "" + } + default { + append tok $c + } + } + } elseif {$in_dq} { + if {$c eq "\""} { + set in_dq 0 + #append tok "\"" + lappend path $tok + set tok "" + } else { + append tok $c + } + } else { + switch -- $c { + . { + if {$tok ne ""} { + lappend path $tok + } + set tok "@@" + } + {[} { + if {$tok ne ""} { + lappend path $tok + } + set in_arr 1 + set tok "" + } + {"} { + if {$tok eq "@@"} { + #set tok "@@\"" + set in_dq 1 + } else { + append tok "\"" + } + } + default { + append tok $c + } + } + } + } + if {$tok ne ""} { + lappend path $tok + } + return $path + } + proc path_to_jq {path} { + set jq "" + foreach p $path { + if {[string match @@* $p]} { + set key [string range $p 2 end] + if {![tomlish::utils::is_barekey $key]} { + set key [subst -nocommands -novariables $key] + set key "\"[tomlish::utils::rawstring_to_Bstring_with_escaped_controls $key]\"" + } + append jq ".$key" + } else { + append jq {[} $p {]} + } + } + return $jq + } + + #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 @@ -2249,16 +2782,78 @@ namespace eval tomlish::utils { return [string map $map $str] } - proc rawstring_is_valid_tomlstring {str} { - #controls are allowed in this direction dict -> toml (they get quoted) + #anything is valid in this direction ?? review + #proc rawstring_is_valid_tomlstring {str} { + # #controls are allowed in this direction dict -> toml (they get quoted) + + # #check any existing escapes are valid + # if {[catch { + # unescape_string $str + # } errM]} { + # return 0 + # } + # return 1 + #} + - #check any existing escapes are valid + #REVIEW - easier way to validate? regex? + #This is not used for the parsing of toml to tomlish, + # but can be used to validate for updating via dict e.g when setting with tomlish::dict::path::setleaf + proc inner_MultiBstring_is_valid_toml {str} { + set without_literal_backslashes [string map [list "\\\\" ""] $str] + #replace only escaped dquotes - use a placeholder - we don't want unescaped runs of dquotes merging. + set without_escaped_dquotes [string map [list "\\\"" ""] $without_literal_backslashes] + + if {[string first "\"\"\"" $without_escaped_dquotes] != -1} { + return 0 + } + #assert - all remaining backslashes are escapes + + #strip remaining dquotes + set dquoteless [string map [list "\"" ""] $without_escaped_dquotes] + #puts stderr "dquoteless: $dquoteless" + + #check any remaining escapes are valid if {[catch { - unescape_string $str + #don't use the returned value - just check it + unescape_string $without_literal_backslashes } errM]} { return 0 } - return 1 + + + variable Bstring_control_map + #remove backslash from control map - we are happy with the remaining escapes (varying length) + set testmap [dict remove $Bstring_control_map "\\" \r \n] + set testval [string map $testmap $dquoteless] + #if they differ - there were raw controls + return [expr {$testval eq $dquoteless}] + } + proc inner_Bstring_is_valid_toml {str} { + set without_literal_backslashes [string map [list "\\\\" ""] $str] + #replace only escaped dquotes - use a placeholder - we don't want unescaped runs of dquotes merging. + set without_escaped_dquotes [string map [list "\\\"" ""] $without_literal_backslashes] + + #plain Bstring can't have unescaped dquotes at tall + if {[string first "\"" $without_escaped_dquotes] != -1} { + return 0 + } + #assert - all remaining backslashes are escapes + + #check any remaining escapes are valid + if {[catch { + #don't use the returned value - just check it + unescape_string $without_literal_backslashes + } errM]} { + return 0 + } + + variable Bstring_control_map + #remove backslash from control map - we are happy with the remaining escapes (varying length) + set testmap [dict remove $Bstring_control_map "\\"] + set testval [string map $testmap $without_escaped_dquotes] + #if they differ - there were raw controls + return [expr {$testval eq $without_escaped_dquotes}] } proc rawstring_is_valid_literal {str} { @@ -2850,48 +3445,9 @@ namespace eval tomlish::utils { } } - proc is_datepart {str} { - set matches [regexp -all {[0-9\-]} $str] - if {[tcl::string::length $str] != $matches} { - return 0 - } - #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) - if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { - return 0 - } - if {$m > 12 || $m == 0} { - return 0 - } - switch -- [expr {$m}] { - 1 - 3 - 5 - 7 - 8 - 10 - 12 { - if {$d > 31 || $d == 0} { - return 0 - } - } - 2 { - if {$d > 29 || $d == 0} { - return 0 - } - if {$d == 29} { - #leapyear check - if {[catch {clock scan $str -format %Y-%m-%d} errM]} { - return 0 - } - } - } - 4 - 6 - 9 - 11 { - if {$d > 30 || $d == 0} { - return 0 - } - } - } - return 1 - } - proc is_localdate {str} { - is_datepart $str - } #allow only hh:mm:ss or hh:mm (no subseconds) + #return 2 when missing seconds proc _is_hms_or_hm_time {val} { set numchars [tcl::string::length $val] if {[regexp -all {[0-9:]} $val] != $numchars} { @@ -2908,6 +3464,7 @@ namespace eval tomlish::utils { if {$hr > 23 || $min > 59} { return 0 } + return 2 ;#missing seconds indicator (can still be used as boolean for true in tcl if we don't care whether hh::mm::ss or hh:mm } elseif {[llength $hms_cparts] == 3} { lassign $hms_cparts hr min sec if {[string length $hr] != 2 || [string length $min] != 2 || [string length $sec] !=2} { @@ -2917,10 +3474,10 @@ namespace eval tomlish::utils { if {$hr > 23 || $min > 59 || $sec > 60} { return 0 } + return 1 } else { return 0 } - return 1 } proc is_timepart {str} { #validate the part after the T (or space) @@ -2946,6 +3503,11 @@ namespace eval tomlish::utils { } if {[llength $dotparts] == 2} { lassign $dotparts hms tail + if {[_is_hms_or_hm_time $hms] == 2} { + #If we have a dot - assume hh::mm::ss required + #toml spec is unclear on this but hh:mm. doesn't seem sensible - REVIEW + return 0 + } #validate tail - which might have +- offset if {[string index $tail end] ni {z Z}} { #from hh:mm:??. @@ -2954,14 +3516,21 @@ namespace eval tomlish::utils { if {![string is digit -strict $fraction]} { return 0 } - if {![_is_hms_or_hm_time $offset]} { + if {[_is_hms_or_hm_time $offset] != 2} { + #RFC3339 indicates offset can be specified as hh:mm or Z - not hh:mm:ss + return 0 + } + } else { + #tail has no +/-, only valid if fraction digits + #toml-test invalid/datetime/second-trailing-dot + if {![string is digit -strict $tail]} { return 0 } } } else { set tail [string range $tail 0 end-1] #expect tail nnnn (from hh:mm::ss.nnnnZ) - #had a dot and a zZ - no other offset valid (?) + #had a dot and a zZ if {![string is digit -strict $tail]} { return 0 } @@ -2970,8 +3539,10 @@ namespace eval tomlish::utils { } else { #no dot (fraction of second) if {[regexp {(.*)[+-](.*)} $str _match hms offset]} { - #validate offset - if {![_is_hms_or_hm_time $offset]} { + #validate offset + #offset of +Z or -Z not valid + if {[_is_hms_or_hm_time $offset] != 2} { + #offset is not of required form hh:mm return 0 } } else { @@ -2994,7 +3565,45 @@ namespace eval tomlish::utils { return 0 } } - proc is_localtime {str} { + + proc is_date-local {str} { + set matches [regexp -all {[0-9\-]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) + if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { + return 0 + } + if {$m > 12 || $m == 0} { + return 0 + } + switch -- [expr {$m}] { + 1 - 3 - 5 - 7 - 8 - 10 - 12 { + if {$d > 31 || $d == 0} { + return 0 + } + } + 2 { + if {$d > 29 || $d == 0} { + return 0 + } + if {$d == 29} { + #leapyear check + if {[catch {clock scan $str -format %Y-%m-%d} errM]} { + return 0 + } + } + } + 4 - 6 - 9 - 11 { + if {$d > 30 || $d == 0} { + return 0 + } + } + } + return 1 + } + proc is_time-local {str} { #time of day without any relation to a specific day or any offset or timezone set numchars [tcl::string::length $str] if {[regexp -all {[0-9\.:]} $str] == $numchars} { @@ -3023,9 +3632,26 @@ namespace eval tomlish::utils { return 0 } } - - #review + proc is_datetime-local {str} { + set norm [string map {" " T} $str] + lassign [split $norm T] dp tp + if {$dp eq "" || $tp eq ""} {return 0} + if {![is_date-local $dp]} {return 0} + if {![is_timepart $tp]} {return 0} + if {![is_time-local $tp]} {return 0} + return 1 + } proc is_datetime {str} { + set norm [string map {" " T} $str] + lassign [split $norm T] dp tp + if {$dp eq "" || $tp eq ""} {return 0} + if {![is_date-local $dp]} {return 0} + if {![is_timepart $tp]} {return 0} + if {[is_time-local $tp]} {return 0} + return 1 + } + #review + proc is_date_or_time_or_datetime {str} { #Essentially RFC3339 formatted date-time - but: #1) allowing seconds to be omitted (:00 assumed) #2) T may be replaced with a single space character TODO - parser support for space in datetime! @@ -3073,7 +3699,7 @@ namespace eval tomlish::utils { if {[string first T $str] > -1} { lassign [split $str T] datepart timepart - if {![is_datepart $datepart]} { + if {![is_date-local $datepart]} { return 0 } if {![is_timepart $timepart]} { @@ -3083,7 +3709,7 @@ namespace eval tomlish::utils { #either a datepart or a localtime #spec: "If you include only the time portion of an RFC 3339 formatted date-time, it will represent that time of day # without any relation to a specific day or any offset or timezone." - if {!([is_datepart $str] || [is_localtime $str])} { + if {!([is_date-local $str] || [is_time-local $str])} { return 0 } } @@ -6029,7 +6655,7 @@ namespace eval tomlish::huddle { set h [huddle::json::json2huddle parse $json] } proc from_dict {d} { - + error "tomlish::huddle::from_dict unimplemented" } #raw - strings must already be processed into values suitable for json e.g surrogate pair escaping @@ -6625,8 +7251,40 @@ namespace eval tomlish::dict { set testtype integer set dval [expr {$dval}] ;#convert e.g 0xDEADBEEF to 3735928559 } - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - FLOAT - BOOL { - #DDDD + FLOAT - BOOL { + set testtype [string tolower $dtype] + } + DATE-LOCAL { + set testtype date-local + } + TIME-LOCAL { + if {[tomlish::utils::_is_hms_or_hm_time $dval] == 2} { + #add seconds for sending to json + set dval "${dval}:00" + } + set testtype time-local + } + DATETIME - DATETIME-LOCAL { + #we expect it to be basically well formed here - this is not validation - just adding possible missing seconds + if {![regexp {([tT\ ])} $dval _ dsep]} { + return -code error -errorcode {TOJSON SYNTAX INVALIDDATE} "Unable to process $dtype '$dval' - missing RFC3339 separator space or T" + } + lassign [split $dval $dsep] dp tail + + #toml allows HH:MM without seconds - but we need to add seconds 00 when passing to external systems + if {![tomlish::utils::is_time-local $tail]} { + #there is some offset component. We aren't checking its syntax here (presumed done when dict building) + regexp {([\+\-zZ])} $tail _ tsep ;#keep tsep for rebuilding + lassign [split $tail $tsep] tp offset ;#offset may be empty if z or Z + } else { + set tp $tail + set tsep "" + set offset "" + } + if {[tomlish::utils::_is_hms_or_hm_time $tp] == 2} { + #need to add seconds + set dval "${dp}${dsep}${tp}:00${tsep}${offset}" + } set testtype [string tolower $dtype] } STRING - MULTISTRING { @@ -6644,10 +7302,6 @@ namespace eval tomlish::dict { #} set dval [tomlish::utils::rawstring_to_jsonstring $dval] } - MULTILITERAL { - #todo - escape newlines for json? - set testtype string - } default { error "convert_typeval_to_tomltest unhandled type $dtype" } @@ -6882,7 +7536,7 @@ namespace eval tomlish::dict { lappend dottedtables_defined $dottedsuper_refpath #ensure empty tables are still represented in the datastructure - tomlish::dict::path::set_endpoint datastructure $dottedsuper_refpath {} ;#set to empty subdict + tomlish::dict::path::setleaf datastructure $dottedsuper_refpath {} 0;#set to empty subdict } else { #added for fixed assumption set ttype [dict get $tablenames_info $dottedsuper_refpath ttype] @@ -6935,7 +7589,7 @@ namespace eval tomlish::dict { #'create' the table dict set tablenames_info $dottedkey_refpath ttype dottedkey_table #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list - tomlish::dict::path::set_endpoint datastructure $dottedkey_refpath {} + tomlish::dict::path::setleaf datastructure $dottedkey_refpath {} 0 lappend dottedtables_defined $dottedkey_refpath # @@ -6994,7 +7648,7 @@ namespace eval tomlish::dict { #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_typeval can distinguish tomlish::log::debug "_process_tomlish_dottedkey>>> context:$context_refpath dottedkey $dottedkeyname kv: $keyval_dict" - tomlish::dict::path::set_endpoint datastructure $fullkey_refpath $keyval_dict + tomlish::dict::path::setleaf datastructure $fullkey_refpath $keyval_dict 0 #remove ? #if {![tomlish::dict::is_typeval $keyval_dict]} { @@ -7015,8 +7669,17 @@ namespace eval tomlish::dict { #} return [dict create dottedtables_defined $dottedtables_defined] } + + #tomlish::dict::from_tomlish is a *basic* programmatic datastructure for accessing the data. # produce a dictionary of keys and values from a tomlish tagged list. + # ---------------------------------------------------------------- + # NOTE: + # can instead produce a list if passed an ARRAY at toplevel + # can produce a single value if passed a MULTISTRING or MULTILIST at toplevel + # These are fragments of tomlish used in recursive calls. + # Such fragments don't represent valid tomlish that can be converted to a toml doc. + # ---------------------------------------------------------------- # dict::from_tomlish is primarily for read access to 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. @@ -7036,7 +7699,7 @@ namespace eval tomlish::dict { # versus #[Data] #temps = [{cpu = 79.5, case = 72.0}] - proc from_tomlish {tomlish} { + proc from_tomlish {tomlish {returnextra 0}} { package require dictn #keep track of which tablenames have already been directly defined, @@ -7099,13 +7762,17 @@ namespace eval tomlish::dict { #value is a dict with keys: ttype, tdefined } + if {![string is list $tomlish]} { + error "tomlish::dict::from_tomlish Supplied value for tomlish does not appear to be a tomlish list. Use tomlish::from_toml to get a tomlish list from toml." + } + log::info "---> dict::from_tomlish processing '$tomlish'<<<" set items $tomlish foreach lst $items { if {[lindex $lst 0] ni $::tomlish::tags} { - error "supplied list 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" + error "tomlish::dict::from_tomlish supplied list 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" } } @@ -7121,12 +7788,13 @@ namespace eval tomlish::dict { #puts "...> item:'$item' tag:'$tag'" switch -exact -- $tag { KEY - DQKEY - SQKEY - INT - FLOAT - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - STRING - LITERAL { - #why would we get individual key item as opposed to DOTTEDKEY? + #we don't require invalid tomlish fragments with these keys in our direct recursion + #(we do support ARRAY, MULTISTING, and MULTILITERAL tomlish fragments below) error "tomlish::dict::from_tomlish error: invalid tag: $tag. At the toplevel, from_tomlish can only process WS NEWLINE COMMENT and compound elements DOTTEDKEY TABLE TABLEARRAY ITABLE MULTILITERAL MULTISTRING" } DOTTEDKEY { - #toplevel dotted key - set dkinfo [_process_tomlish_dottedkey $item] + #toplevel dotted key empty context_refpath + set dkinfo [_process_tomlish_dottedkey $item {}] lappend dottedtables_defined {*}[dict get $dkinfo dottedtables_defined] #at any level - we don't expect any more DOTTEDKEY records in a tomlish structure after TABLE or TABLEARRAY are encountered #as those records should encapsulate their own dottedkeys @@ -7221,7 +7889,7 @@ namespace eval tomlish::dict { dict set tablenames_info $tablearray_refpath ttype header_tablearray #dict set datastructure {*}$norm_segments [list type ARRAY value {}] #create array along with empty array-item at position zero - tomlish::dict::path::set_endpoint datastructure $tablearray_refpath [list type ARRAY value {{}}] + tomlish::dict::path::setleaf datastructure $tablearray_refpath [list type ARRAY value {{}}] 0 set arrayitem_refpath [list {*}$tablearray_refpath 0] #set ARRAY_ELEMENTS [list] } else { @@ -7375,7 +8043,7 @@ namespace eval tomlish::dict { dict set tablenames_info $refpath ttype unknown_header #ensure empty tables are still represented in the datastructure #dict set datastructure {*}$supertable [list] - tomlish::dict::path::set_endpoint datastructure $refpath {} + tomlish::dict::path::setleaf datastructure $refpath {} 0 } else { #supertable has already been created - and may be defined - but even if defined we can add subtables unless it is of type itable if {[dict get $tablenames_info $refpath ttype] eq "header_tablearray"} { @@ -7420,7 +8088,7 @@ namespace eval tomlish::dict { #We are 'defining' this table's keys and values here (even if empty) #dict set datastructure {*}$norm_segments [list] ;#ensure table still represented in datastructure even if we add no keyvals here - tomlish::dict::path::set_endpoint datastructure $table_refpath {} ;#ensure table still represented in datastructure even if we add no keyvals here + tomlish::dict::path::setleaf datastructure $table_refpath {} 0;#ensure table still represented in datastructure even if we add no keyvals here } else { if {[dict get $tablenames_info $table_refpath ttype] eq "header_tablearray"} { #e.g tomltest invalid/table/duplicate-table-array2 @@ -7492,6 +8160,7 @@ namespace eval tomlish::dict { } } ARRAY { + #invalid at toplevel of a 'complete' tomlish structure - but we support it here for recursive fragment processing #arrays in toml are allowed to contain mixtures of types set datastructure [list] log::debug "--> processing array: $item" @@ -7540,6 +8209,8 @@ namespace eval tomlish::dict { } } MULTILITERAL { + #Not for toplevel of complete tomlish - (recursive fragment processing) + #triple squoted string #first newline stripped only if it is the very first element #(ie *immediately* following the opening delims) @@ -7583,6 +8254,7 @@ namespace eval tomlish::dict { set datastructure $stringvalue } MULTISTRING { + #Not for toplevel of complete tomlish - (recursive fragment processing) #triple dquoted string log::debug "---> tomlish::dict::from_tomlish processing multistring: $item" set stringvalue "" @@ -7696,82 +8368,394 @@ namespace eval tomlish::dict { } } } - return $datastructure + if {!$returnextra} { + return $datastructure + } else { + return [dict create datastructure $datastructure tablenames_info $tablenames_info] + } + } +} +namespace eval tomlish::path { + namespace export {[a-z]*}; # Convention: export all lowercase + + set test_tomlish [tomlish::from_toml { } #comment {z=1} {x.y=2 #xy2} {[[shop.product]] #product1} {x=[ #array1} {11 #val1} {, 12 #val2} {]} {[unrelated.' etc ']} {a.b={c=666}} {a.x={}} {[[shop.product]]} {x="test"} {[shop]} {name="myshop"}] + + proc get {tomlish {path {}}} { + if {$path eq ""} { + return $tomlish + } + if {[string index $path 0] in [list . "\["]} { + set path [tomlish::utils::jq_to_path $path] + } + + #at the cost of some performance, sanity check that the tomlish is valid + if {[catch {tomlish::to_dict $tomlish} d]} { + error "tomlish::path::get error supplied tomlish is malformed\nerrmsg: $d" + } + #since we have the dict - test the path is valid + if {![tomlish::dict::path::exists $d $path]} { + error "tomlish::path::get - path \"$path\" not found in tomlish $tomlish" + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + set tomlish [lrange $tomlish 1 end] + } + ::set pathsofar [list] + ::set tomlitems [list] ;#reducing set. 2 element list {keypath itemlist} + foreach record $tomlish { + lappend tomlitems [list {} [list $record]] ;#root records + } + + ::set dictsubpath [list] ;#reset at every index encounter? + foreach p $path { + ::lappend pathsofar $p + set sublist [list] + if {[string range $p 0 1] eq "@@"} { + set realsearchkey [string range $p 2 end] + lappend dictsubpath $realsearchkey + foreach path_items $tomlitems { + lassign $path_items subpath tlist + lappend subpath $realsearchkey + foreach item $tlist { + set tp [lindex $item 0] + switch -- $tp { + WS - NEWLINE - COMMENT { + } + DOTTEDKEY { + #can occur at toplevel (before others) or within other elements + set keyinfo [tomlish::get_dottedkey_info $item] + set keys_raw [dict get $keyinfo keys_raw] + puts stderr "subpath:$subpath -->DOTTEDKEY keys_raw: $keys_raw" + #may not be enough keys_raw for subpath - but there could be further ITABLES to continue the dict further + set prefixparts [lrange $keys_raw 0 [llength $subpath]-1] + set is_kmatch 1 ;#default assumption only + foreach dsub $subpath kpart $prefixparts { + if {$dsub ne $kpart} { + set is_kmatch 0 + } + } + if {$is_kmatch} { + if {[llength $keys_raw] == [llength $subpath]} { + set subpath [list] + #e.g {DOTTEDKEY {{KEY xxx}} = {WS { }} {STRING blah}} + lappend sublist [list $subpath [lrange $item 3 end]] + } else { + lappend sublist [list $subpath [list $item]] + } + } + } + ITABLE { + #subelement only + set itablechildren [lrange $item 1 end] + puts stderr "subpath:$subpath -->ITABLE records: $itablechildren" + set nextpath [lmap v $subpath {string cat @@ $v}] + set results [tomlish::path::get $itablechildren $nextpath] + set subpath [list] + puts "--> lappending [list $subpath $results]" + lappend sublist [list $subpath $results] + } + TABLEARRAY { + #toplevel only + set fulltablename [lindex $item 1] + set normalise 1 + set tparts [tomlish::toml::tablename_split $fulltablename $normalise] + if {[llength $tparts] < [llength $subpath]} {continue} ;#not enough parts to satisfy current subpath query + set prefixparts [lrange $tparts 0 [llength $subpath]-1] + set is_tmatch 1 ;#default assumption only + foreach dsub $subpath tpart $prefixparts { + if {$dsub ne $tpart} { + set is_tmatch 0 + } + } + #TODO reference arrays + if {$is_tmatch} { + if {[llength $tparts] == [llength $subpath]} { + set subpath [list] + lappend sublist [list $subpath [lrange $item 2 end]] + } else { + #TODO + set subpath 0 + lappend sublist [list $subpath [list $item]] ;#add entire TABLE line + } + } + } + TABLE { + #toplevel only + set fulltablename [lindex $item 1] + set normalise 1 + set tparts [tomlish::toml::tablename_split $fulltablename $normalise] + if {[llength $tparts] < [llength $subpath]} {continue} ;#not enough parts to satisfy current subpath query + set prefixparts [lrange $tparts 0 [llength $subpath]-1] + set is_tmatch 1 ;#default assumption only + foreach dsub $subpath tpart $prefixparts { + if {$dsub ne $tpart} { + set is_tmatch 0 + } + } + if {$is_tmatch} { + if {[llength $tparts] == [llength $subpath]} { + set subpath [list] + lappend sublist [list $subpath [lrange $item 2 end]] + } else { + #leave subpath + lappend sublist [list $subpath [list $item]] ;#add entire TABLE line + } + } + } + ARRAY { + #subelement only + } + + } + } + } + } else { + #index + #will never occur at toplevel (dict::path::exists already ruled it out) + foreach path_items $toml_items { + lassign $path_items subpath $tlist + set tp [lindex $tlist 0] + switch -- $tp { + ARRAY { + } + } + } + } + #temp + puts stdout "pathsofar: $pathsofar" + puts stdout [punk::lib::showdict -roottype list $sublist] + set tomlitems $sublist + } + + #REVIEW + if {[llength $tomlitems] == 1} { + return [lindex $tomlitems 0 1] + } + set result [list] + foreach i $tomlitems { + lappend result [lindex $i 1] + } + return $result + #return [lindex $tomlitems 1] } + } namespace eval tomlish::dict::path { - #access tomlish dict structure + + #access tomlish dict structure namespace export {[a-z]*}; # Convention: export all lowercase - #access with path such as: @@k @@k 0 @@k end where dict keys marked with @@ and plain values are list indices into in {type ARRAY value } - #leaf elements returned as structured {type value } + #access with path such as: @@k @@k 0 @@k end where dict keys marked with @@ and plain values are list indices into in {type ARRAY value } + #leaf elements returned as structured {type value } proc get {dictval {path {}}} { if {$path eq ""} { return $dictval } + if {[string index $path 0] in [list . "\["]} { + set path [tomlish::utils::jq_to_path $path] + } + ::set data $dictval ::set pathsofar [list] + ::set i 0 foreach p $path { ::lappend pathsofar $p if {[string range $p 0 1] eq "@@"} { + #dict key ::set data [dict get $data [string range $p 2 end]] } else { - if {![tomlish::dict::is_typeval $data]} { - error "tomlish::dict::path::get error bad path $path. Attempt to access table as array at subpath $pathsofar." - } - if {[dict get $data type] ne "ARRAY"} { - error "tomlish::dict::get error bad path $path. Subpath $pathsofar is not an array." + #ARRAY or raw list index + if {[llength $pathsofar] > 1 && [string trim [lindex $pathsofar $i-1]] eq ""} { + #previous path was query for entire list - result is a raw list, not a dict + if {[string trim $p] eq ""} { + #review - multiple {[]} in a row in the path is pretty suspicious - raise error + error "tomlish::dict::path::get error - multiple empty indices in a row not supported" + } + ::set data [lindex $data $p] + } else { + if {![tomlish::dict::is_typeval $data]} { + error "tomlish::dict::path::get error bad path $path. Attempt to access table or other value as array at subpath $pathsofar." + } + if {[dict get $data type] ne "ARRAY"} { + error "tomlish::dict::get error bad path $path. Subpath $pathsofar is not an array." + } + ::set arrdata [dict get $data value] + #when $p is empty string (or whitespace) - lindex returns entire list (or empty list) + # - this corresponds to jq: {[]} or path {""} + ::set data [lindex $arrdata $p] } - ::set arrdata [dict get $data value] - ::set data [lindex $arrdata $p] } + incr i } return $data } + proc exists {dictval path} { + #completely empty path considered to exist - review + if {[string index $path 0] in [list . {[}]} { + set path [tomlish::utils::jq_to_path $path] + } ::set data $dictval ::set pathsofar [list] ::set exists 1 + ::set i 0 foreach p $path { ::lappend pathsofar $p if {[string range $p 0 1] eq "@@"} { + #dict key ::set k [string range $p 2 end] if {![dict exists $data $k]} { return 0 } ::set data [dict get $data $k] } else { - if {![tomlish::dict::is_typeval $data]} { - return 0 + #ARRAY or raw list index + if {[llength $pathsofar] > 1 && [string trim [lindex $pathsofar $i-1]] eq ""} { + #previous path was query for entire list - result is not a dict + if {[string trim $p] eq ""} { + #review - multiple {[]} in a row in the path is pretty suspicious - raise error + error "tomlish::dict::path::exists error - multiple empty indices in a row not supported" + #or just leave data as is? + } else { + ::set intp [tomlish::system::lindex_resolve_basic $data $p] + if {$intp == -1} { + return 0 + } + ::set data [lindex $data $p] + } + } else { + if {![tomlish::dict::is_typeval $data]} { + return 0 + } + if {[dict get $data type] ne "ARRAY"} { + return 0 + } + #special case for empty path syntax {jq: [] path: ""} meaning retrieve all elements in list + ::set arrdata [dict get $data value] + if {[string trim $p] eq ""} { + #we have confirmed above it is an ARRAY - we consider an empty list to exist. + #UUU + ::set data $arrdata + } else { + #for 'exists' we need to avoid lindex returning empty string for out of bounds + ::set intp [tomlish::system::lindex_resolve_basic $arrdata $p] ;#handle index math (end-1 etc) + if {$intp == -1} { + #out of bounds + return 0 + } + ::set data [lindex $arrdata $p] + } } - if {[dict get $data type] ne "ARRAY"} { - return 0 + } + incr i + } + return $exists + } + + + #raise error for invalid + proc validate_typeval {typeval} { + set valtype [dict get $typeval type] + set rawval [dict get $typeval value] + switch -- $valtype { + INT { + if {![tomlish::utils::is_int $rawval]} { + return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml int: '$rawval'" } - ::set arrdata [dict get $data value] - ::set intp [tomlish::system::lindex_resolve_basic $arrdata $p] ;#handle index math (end-1 etc) - if {$intp == -1} { - #out of bounds - return 0 + } + BOOL { + #toml only accepts lower case true and false + #review + if {$rawval ni {true false}} { + return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml boolean (true|false): '$rawval'" + } + } + FLOAT { + if {![tomlish::utils::is_float $rawval]} { + return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml float: '$rawval'" + } + } + DATETIME { + #review - accept even when more specific types apply? + if {![tomlish::utils::is_datetime]} { + return -code error -errorcode {TOML TYPE NOT_DATETIME} "validate_typeval value is not a valid toml datetime: '$rawval'" + } + } + DATETIME-LOCAL { + if {![tomlish::utils::is_datetime-local]} { + return -code error -errorcode {TOML TYPE NOT_DATETIME-LOCAL} "validate_typeval value is not a valid toml datetime-local: '$rawval'" + } + } + DATE-LOCAL { + if {![tomlish::utils::is_date-local]} { + return -code error -errorcode {TOML TYPE NOT_DATE-LOCAL} "validate_typeval value is not a valid toml date-local: '$rawval'" + } + } + TIME-LOCAL { + if {![tomlish::utils::is_time-local]} { + return -code error -errorcode {TOML TYPE NOT_TIME-LOCAL} "validate_typeval value is not a valid toml time-local: '$rawval'" + } + } + ARRAY { + if {$rawval eq ""} { + return + } + foreach el $rawval { + validate_typeval $el + } + } + STRING { + if {![tomlish::utils::inner_Bstring_is_valid_toml $rawval]} { + return -code error -errorcode {TOML TYPE NOT_BSTRING} "validate_typeval value is not a valid toml basic string: '$rawval'" } - ::set data [lindex $arrdata $p] + } + MULTISTRING { + #multistring as a single value + #UUU + if {![tomlish::utils::inner_MultiBstring_is_valid_toml $rawval]} { + return -code error -errorcode {TOML TYPE NOT_MLBSTRING} "validate_typeval value is not a valid toml multistring: '$rawval'" + } + } + LITERAL { + #todo? + } + MULTILITERAL { + #? + } + default { + return -code error -errorcode {TOML TYPE UNRECOGNISED} "validate_typeval does not recognise type '$valtype'" } } - return $exists } #a restricted analogy of 'dictn set' - #set 'endpoints' - don't create intermediate paths + #set 'leaf' values only - don't create intermediate paths # can replace an existing dict with another dict # can create a key when key at tail end of path is a key (ie @@keyname, not index) # can replace an existing {type value value } # with added restriction that if is ARRAY the new must also be ARRAY - proc set_endpoint {dictvariable path value} { + + package require struct::list + proc setleaf {dictvariable path value {validate 1}} { + if {[string index $path 0] in [list . {[}]} { + set path [tomlish::utils::jq_to_path $path] + } + upvar $dictvariable dict_being_edited + if {![info exists dict_being_edited]} { + error "tomlish::dict::path::setleaf error - supplied value for 'dictvariable' doesn't seem to be the name of an existing variable" + } ::set data $dict_being_edited ::set pathsofar [list] if {!([tomlish::dict::is_typeval $value] || [tomlish::dict::is_typeval_dict $value 0])} { #failed check of supplied value as basic type, or a sub-dict structure (not checking arrays) - error "tomlish::dict::path::set_endpoint error - value must already be in the tomlish form {type value } or be a dict with such forms as leaves" + error "tomlish::dict::path::setleaf error - value must already be in the tomlish form {type value } or be a dict with such forms as leaves" + } + if {$validate && [tomlish::dict::is_typeval $value]} { + #validate value element of $value is correct for type element + if {[catch {validate_typeval $value} errM]} { + return -code error -errorcode {TOMLISH VALIDATION TYPEFAIL} $errM + } } foreach p $path { ::lappend pathsofar $p @@ -7783,28 +8767,28 @@ namespace eval tomlish::dict::path { #} ::set varname v[incr v] - if {$pathsofar eq $path} { - #see if endpoint of the path given already exists + if {[struct::list equal $pathsofar $path]} { + #see if leaf of the path given already exists if {[dict exists $data $k]} { ::set endpoint [dict get $data $k] if {[tomlish::dict::is_typeval $endpoint]} { set existing_tp [dict get $endpoint type] if {![tomlish::dict::is_typeval $value]} { - error "tomlish::dict::path::set_endpoint error Unable to overwrite subpath '$pathsofar' which is of type $existing_tp with sub-dict. Supplied value not {type value value val } with sub-dict: $value" + error "tomlish::dict::path::setleaf error path '$path'. Cannot overwrite {type val } with sub-dict: $value" } switch -- [dict get $endpoint type] { ARRAY { #disallow overwriting array - unless given value is an ARRAY? REVIEW if {[dict get $value type] ne "ARRAY"} { - error "tomlish::dict::path::set_endpoint error bad path '$path'. Cannot overwrite array with non-array: $value" + error "tomlish::dict::path::setleaf error bad path '$path'. Cannot overwrite array with non-array: $value" } } default { @@ -7855,9 +8839,9 @@ namespace eval tomlish::dict::path { } } } else { - #endpoint is a typeval dict not a plain typeval - only allow overwrite with a typeval dict + #leaf is a typeval dict not a plain typeval - only allow overwrite with a typeval dict if {![tomlish::dict::is_typeval_dict $value 0]} { - error "tomlish::dict::path::set_endpoint error path '$path'. Cannot overwrite sub-dict (size: [dict size $endpoint]) with non sub-dict: $value" + error "tomlish::dict::path::setleaf error path '$path'. Cannot overwrite sub-dict (size: [dict size $endpoint]) with non sub-dict: $value" } } ::set $varname $value @@ -7867,7 +8851,7 @@ namespace eval tomlish::dict::path { ::set arrdata [dict get $data value] set idx [tomlish::system::lindex_resolve_basic $arrdata $p] if {$idx == -1} { - error "tomlish::dict::path::set_endpoint error bad path '$path'. No existing element at $p" + error "tomlish::dict::path::setleaf error bad path '$path'. No existing element at $p" } ::set data [lindex $arrdata $p] ::set $varname $data @@ -7897,7 +8881,7 @@ namespace eval tomlish::dict::path { if {[string match @@* $k]} { #dict key #dict set $nextvarname $k $newval - set_endpoint $nextvarname [list $k] $newval + setleaf $nextvarname [list $k] $newval 0 } else { #list index ::set nextarr [dict get $nextval value] @@ -7913,6 +8897,9 @@ namespace eval tomlish::dict::path { #path must be to a {type ARRAY value } #REVIEW - how to lappend to deep mixed dict/array structure without rewriting whole datastructure? proc lappend {dictvariable path args} { + if {[string index $path 0] in [list . {[}]} { + set path [tomlish::utils::jq_to_path $path] + } upvar $dictvariable dict_being_edited ::set data $dict_being_edited ::set pathsofar [list] @@ -7933,7 +8920,7 @@ namespace eval tomlish::dict::path { } ::set varname v[incr v] - if {$pathsofar eq $path} { + if {[struct::list equal $pathsofar $path]} { #see if endpoint of the path given is an ARRAY ::set endpoint [dict get $data $k] if {![tomlish::dict::is_typeval $endpoint]} { @@ -7961,7 +8948,7 @@ namespace eval tomlish::dict::path { error "tomlish::dict::path::lappend error bad path $path. Subpath $pathsofar is not an array." } ::set varname v[incr v] - if {$pathsofar eq $path} { + if {[struct::list equal $pathsofar $path]} { if {[dict get $data type] ne "ARRAY"} { error "tomlish::dict::path::lappend error bad path $path. Parent path is not an array." } @@ -8160,6 +9147,8 @@ tcl::namespace::eval tomlish::app { #review chan configure $ch_input -translation lf + chan configure $ch_output -translation lf + if {[catch { set json [read $ch_input] }]} { @@ -8291,6 +9280,25 @@ namespace eval tomlish::system { } } + #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features + #safe in that we don't evaluate the expression as a string. + proc offset_expr {expression} { + #required for tcl < 8.7 range command (lseq not available) + set expression [tcl::string::map {_ {}} $expression] + if {[tcl::string::is integer -strict $expression]} { + return [expr {$expression}] + } + if {[regexp {(.*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { + if {$op eq "-"} { + return [expr {$a - $b}] + } else { + return [expr {$a + $b}] + } + } else { + error "bad expression '$expression': must be integer?\[+-\]integer?" + } + } + if {[info commands ::lseq] ne ""} { #tcl 8.7+ lseq significantly faster, especially for larger ranges #The internal rep can be an 'arithseries' with no string representation diff --git a/src/vfs/_vfscommon.vfs/modules/dictn-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/dictn-0.1.2.tm similarity index 91% rename from src/vfs/_vfscommon.vfs/modules/dictn-0.1.1.tm rename to src/vfs/_vfscommon.vfs/modules/dictn-0.1.2.tm index c9ef87f2..2ed2b1ef 100644 --- a/src/vfs/_vfscommon.vfs/modules/dictn-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/dictn-0.1.2.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application dictn 0.1.1 +# Application dictn 0.1.2 # Meta platform tcl # Meta license # @@ Meta End @@ -74,15 +74,17 @@ proc ::dictn::get {dictval {path {}}} { return [dict get $dictval {*}$path] } -proc ::dictn::getdef {dictval path default} { - return [dict getdef $dictval {*}$path $default] -} - -proc ::dictn::getwithdefault {dictval path default} { - return [dict getdef $dictval {*}$path $default] -} if {[info commands ::tcl::dict::getdef] ne ""} { + #tcl 9+ + proc ::dictn::getdef {dictval path default} { + return [dict getdef $dictval {*}$path $default] + } + + proc ::dictn::getwithdefault {dictval path default} { + return [dict getdef $dictval {*}$path $default] + } + proc ::dictn::incr {dictvar path {increment {}} } { if {$increment eq ""} { ::set increment 1 @@ -101,6 +103,21 @@ if {[info commands ::tcl::dict::getdef] ne ""} { } } } else { + #tcl < 9 + proc ::dictn::getdef {dictval path default} { + if {[tcl::dict::exists $dictval {*}$path]} { + return [tcl::dict::get $dictval {*}$path] + } else { + return $default + } + } + proc ::dictn::getwithdefault {dictval path default} { + if {[tcl::dict::exists $dictval {*}$path]} { + return [tcl::dict::get $dictval {*}$path] + } else { + return $default + } + } proc ::dictn::incr {dictvar path {increment {}} } { if {$increment eq ""} { ::set increment 1 @@ -344,6 +361,6 @@ proc ::dictn::with {dictvar path args} { ## Ready package provide dictn [namespace eval dictn { variable version - ::set version 0.1.1 + ::set version 0.1.2 }] return \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/modpod-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/modpod-0.1.3.tm new file mode 100644 index 00000000..44da4684 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/modpod-0.1.3.tm @@ -0,0 +1,704 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application modpod 0.1.3 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin modpod_module_modpod 0 0.1.3] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require modpod] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of modpod +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by modpod +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::set ;#review +package require punk::lib +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod::class { + #*** !doctools + #[subsection {Namespace modpod::class}] + #[para] class definitions + if {[info commands [namespace current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod { + namespace export {[a-z]*}; # Convention: export all lowercase + + variable connected + if {![info exists connected(to)]} { + set connected(to) list + } + variable modpodscript + set modpodscript [info script] + if {[string tolower [file extension $modpodscript]] eq ".tcl"} { + set connected(self) [file dirname $modpodscript] + } else { + #expecting a .tm + set connected(self) $modpodscript + } + variable loadables [info sharedlibextension] + variable sourceables {.tcl .tk} ;# .tm ? + + #*** !doctools + #[subsection {Namespace modpod}] + #[para] Core API functions for modpod + #[list_begin definitions] + + + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + #old tar connect mechanism - review - not needed? + proc connect {args} { + puts stderr "modpod::connect--->>$args" + set argd [punk::args::get_dict { + @id -id ::modpod::connect + -type -default "" + @values -min 1 -max 1 + path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" + } $args] + catch { + punk::lib::showdict $argd ;#heavy dependencies + } + set opt_path [dict get $argd values path] + variable connected + set original_connectpath $opt_path + set modpodpath [modpod::system::normalize $opt_path] ;# + + if {$modpodpath in $connected(to)} { + return [dict create ok ALREADY_CONNECTED] + } + lappend connected(to) $modpodpath + + set connected(connectpath,$opt_path) $original_connectpath + set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] + + set connected(location,$modpodpath) [file dirname $modpodpath] + set connected(startdata,$modpodpath) -1 + set connected(type,$modpodpath) [dict get $argd opts -type] + set connected(fh,$modpodpath) "" + + if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { + set connected(type,$modpodpath) "unwrapped" + lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] + + } else { + #connect to .tm but may still be unwrapped version available + lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + set this_pkg_tm_folder [file dirname $modpodpath] + if {$connected(type,$modpodpath) ne "unwrapped"} { + #Not directly connected to unwrapped version - but may still be redirected there + set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] + if {[file exists $unwrappedFolder]} { + #folder with exact version-match must exist for redirect to 'unwrapped' + set con(type,$modpodpath) "modpod-redirecting" + } + } + + } + set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" + set connected(tmfile,$modpodpath) + set tail_segments [list] + set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] + set lcase_modulepaths [string tolower [tcl::tm::list]] + foreach lc_mpath $lcase_modulepaths { + set mpath_segments [file split $lc_mpath] + if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] + break + } + } + if {[llength $tail_segments]} { + set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require + } else { + set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] + } + + switch -exact -- $connected(type,$modpodpath) { + "modpod-redirecting" { + #redirect to the unwrapped version + set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] + + } + "unwrapped" { + if {[info commands ::thread::id] ne ""} { + set from [pid],[thread::id] + } else { + set from [pid] + } + #::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" + return [list ok ""] + } + default { + #autodetect .tm - zip/tar ? + #todo - use vfs ? + + #connect to tarball - start at 1st header + set connected(startdata,$modpodpath) 0 + set fh [open $modpodpath r] + set connected(fh,$modpodpath) $fh + fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} + + if {$connected(startdata,$modpodpath) >= 0} { + #verify we have a valid tar header + if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { + seek $fh $connected(startdata,$modpodpath) start + return [list ok $fh] + } else { + #error "cannot verify tar header" + } + } + lpop connected(to) end + set connected(startdata,$modpodpath) -1 + unset connected(fh,$modpodpath) + catch {close $fh} + return [dict create err {Does not appear to be a valid modpod}] + } + } + } + proc disconnect {{modpod ""}} { + variable connected + if {![llength $connected(to)]} { + return 0 + } + if {$modpod eq ""} { + puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" + set modpod [lindex $connected(to) end] + } + + if {[set posn [lsearch $connected(to) $modpod]] == -1} { + puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" + return 0 + } + if {[string length $connected(fh,$modpod)]} { + close $connected(fh,$modpod) + } + array unset connected *,$modpod + set connected(to) [lreplace $connected(to) $posn $posn] + return 1 + } + proc get {args} { + set argd [punk::args::get_dict { + -from -default "" -help "path to pod" + *values -min 1 -max 1 + filename + } $args] + set frompod [dict get $argd opts -from] + set filename [dict get $argd values filename] + + variable connected + #//review + set modpod [::modpod::system::connect_if_not $frompod] + set fh $connected(fh,$modpod) + if {$connected(type,$modpod) eq "unwrapped"} { + #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder + if {[string range $filename 0 0 eq "/"]} { + #absolute path (?) + set path [file join $connected(location,$modpod) .. [string trim $filename /]] + } else { + #relative path - use #modpod-xxx as base + set path [file join $connected(location,$modpod) $filename] + } + set fd [open $path r] + #utf-8? + #fconfigure $fd -encoding iso8859-1 -translation binary + return [list ok [lindex [list [read $fd] [close $fd]] 0]] + } else { + #read from vfs + puts stderr "get $filename from wrapped pod '$frompod' not implemented" + } + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace modpod ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace modpod::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + proc is_valid_tm_version {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionparts $versionparts]]} { + return 1 + } else { + return 0 + } + } + + #zipfile is a pure zip at this point - ie no script/exe header + proc make_zip_modpod {args} { + set argd [punk::args::get_dict { + @id -id ::modpod::lib::make_zip_modpod + -offsettype -default "archive" -choices {archive file} -help\ + "Whether zip offsets are relative to start of file or start of zip-data within the file. + 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, + but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) + info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. + -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" + @values -min 2 -max 2 + zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" + outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" + } $args] + set zipfile [dict get $argd values zipfile] + set outfile [dict get $argd values outfile] + set opt_offsettype [dict get $argd opts -offsettype] + + + set mount_stub [string map [list %offsettype% $opt_offsettype] { + #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. + #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. + #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% + if {[catch {file normalize [info script]} modfile]} { + error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" + } + if {$modfile eq "" || ![file exists $modfile]} { + error "modpod zip stub error. Unable to determine module path" + } + set moddir [file dirname $modfile] + set mod_and_ver [file rootname [file tail $modfile]] + lassign [split $mod_and_ver -] moduletail version + if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { + source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm + } else { + #determine module namespace so we can mount appropriately + proc intersect {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return {}} + if {[llength $B] > [llength $A]} { + set res $A + set A $B + set B $res + } + set res {} + foreach x $A {set ($x) {}} + foreach x $B { + if {[info exists ($x)]} { + lappend res $x + } + } + return $res + } + set lcase_tmfile_segments [string tolower [file split $moddir]] + set lcase_modulepaths [string tolower [tcl::tm::list]] + foreach lc_mpath $lcase_modulepaths { + set mpath_segments [file split $lc_mpath] + if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail + break + } + } + if {[llength $tail_segments]} { + set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require + set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver + } else { + set fullpackage $moduletail + set mount_at #modpod/#mounted-modpod-$mod_and_ver + } + + if {[info commands tcl::zipfs::mount] ne ""} { + #argument order changed to be consistent with vfs::zip::Mount etc + #early versions: zipfs::Mount mountpoint zipname + #since 2023-09: zipfs::Mount zipname mountpoint + #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) + #This is presumably related to // being interpreted as a network path + set mountpoints [dict keys [tcl::zipfs::mount]] + if {"//zipfs:/$mount_at" ni $mountpoints} { + #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it + if {[catch { + #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) + #puts "tcl::zipfs::mount $modfile $mount_at" + tcl::zipfs::mount $modfile $mount_at + } errM]} { + #try old api + if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { + puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" + puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" + } + } + if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" + #tcl::zipfs::unmount //zipfs:/$mount_at + error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" + } + } + # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form + source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + } else { + #fallback to slower vfs::zip + #NB. We don't create the intermediate dirs - but the mount still works + if {![file exists $moddir/$mount_at]} { + if {[catch {package require vfs::zip} errM]} { + set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" + append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." + append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" + error $msg + } else { + set fd [vfs::zip::Mount $modfile $moddir/$mount_at] + if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + vfs::zip::Unmount $fd $moddir/$mount_at + error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" + } + } + } + source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + } + } + #zipped data follows + }] + #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? + append mount_stub \x1A + modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype + + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace modpod::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval modpod::system { + #*** !doctools + #[subsection {Namespace modpod::system}] + #[para] Internal functions that are not part of the API + + #deflate,store only supported + + #zipfile here is plain zip - no script/exe prefix part. + proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { + set inzip [open $zipfile r] + fconfigure $inzip -encoding iso8859-1 -translation binary + set out [open $outfile w+] + fconfigure $out -encoding iso8859-1 -translation binary + puts -nonewline $out $mount_stub + set stuboffset [tell $out] + lappend report "stub size: $stuboffset" + fcopy $inzip $out + close $inzip + + set size [tell $out] + lappend report "modpod::system::make_mountable_zip" + lappend report "tmfile : [file tail $outfile]" + lappend report "output size : $size" + lappend report "offsettype : $offsettype" + + if {$offsettype eq "file"} { + #make zip offsets relative to start of whole file including prepended script. + #same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 + #2025 - zipfs mkimg fixed to use 'archive' offset. + #not editable by 7z,nanazip,peazip + + #we aren't adding any new files/folders so we can edit the offsets in place + + #Now seek in $out to find the end of directory signature: + #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text + if {$size < 65559} { + set tailsearch_start 0 + } else { + set tailsearch_start [expr {$size - 65559}] + } + seek $out $tailsearch_start + set data [read $out] + #EOCD - End of Central Directory record + #PK\5\6 + set start_of_end [string last "\x50\x4b\x05\x06" $data] + #set start_of_end [expr {$start_of_end + $seek}] + #incr start_of_end $seek + set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] + + lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" + + seek $out $filerelative_eocd_posn + set end_of_ctrl_dir [read $out] + binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + + lappend report "End of central directory: [array get eocd]" + seek $out [expr {$filerelative_eocd_posn+16}] + + #adjust offset of start of central directory by the length of our sfx stub + puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] + flush $out + + seek $out $filerelative_eocd_posn + set end_of_ctrl_dir [read $out] + binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + + # 0x06054b50 - end of central dir signature + puts stderr "$end_of_ctrl_dir" + puts stderr "comment_len: $eocd(comment_len)" + puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" + lappend report "New dir offset: $eocd(diroffset)" + lappend report "Adjusting $eocd(totalnum) zip file items." + catch { + punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies + } + + seek $out $eocd(diroffset) + for {set i 0} {$i <$eocd(totalnum)} {incr i} { + set current_file [tell $out] + set fileheader [read $out 46] + puts -------------- + puts [ansistring VIEW -lf 1 $fileheader] + puts -------------- + #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + + binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + set ::last_header $fileheader + + puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" + puts "ver: $x(version)" + puts "method: $x(method)" + + #PK\1\2 + #33639248 dec = 0x02014b50 - central directory file header signature + if { $x(sig) != 33639248 } { + error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" + } + + foreach size $x(lengths) var {filename extrafield comment} { + if { $size > 0 } { + set x($var) [read $out $size] + } else { + set x($var) "" + } + } + set next_file [tell $out] + lappend report "file $i: $x(offset) $x(sizes) $x(filename)" + + seek $out [expr {$current_file+42}] + puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] + + #verify: + flush $out + seek $out $current_file + set fileheader [read $out 46] + lappend report "old $x(offset) + $stuboffset" + binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + lappend report "new $x(offset)" + + seek $out $next_file + } + } + + close $out + #pdict/showdict reuire punk & textlib - ie lots of dependencies + #don't fall over just because of that + catch { + punk::lib::showdict -roottype list -chan stderr $report + } + #puts [join $report \n] + return + } + + proc connect_if_not {{podpath ""}} { + upvar ::modpod::connected connected + set podpath [::modpod::system::normalize $podpath] + set docon 0 + if {![llength $connected(to)]} { + if {![string length $podpath]} { + error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" + } else { + set docon 1 + } + } else { + if {![string length $podpath]} { + set podpath [lindex $connected(to) end] + puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" + } else { + if {$podpath ni $connected(to)} { + set docon 1 + } + } + } + if {$docon} { + if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { + error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" + } else { + return $podpath + } + } + #we were already connected + return $podpath + } + + proc myversion {} { + upvar ::modpod::connected connected + set script [info script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" + } + set fname [file tail [file rootname [file normalize $script]]] + set scriptdir [file dirname $script] + + if {![string match "#modpod-*" $fname]} { + lassign [lrange [split $fname -] end-1 end] _pkgname version + } else { + lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version + if {![string length $version]} { + #try again on the name of the containing folder + lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version + #todo - proper walk up the directory tree + if {![string length $version]} { + #try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) + lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version + } + } + } + + #tarjar::Log debug "'myversion' determined version for [info script]: $version" + return $version + } + + proc myname {} { + upvar ::modpod::connected connected + set script [info script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" + } + return $connected(fullpackage,$script) + } + proc myfullname {} { + upvar ::modpod::connected connected + set script [info script] + #set script [::tarjar::normalize $script] + set script [file normalize $script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" + } + return $::tarjar::connected(fullpackage,$script) + } + proc normalize {path} { + #newer versions of Tcl don't do tilde sub + + #Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) + # we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. + set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. + set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after + set path [file normalize $path] + #set path [string tolower $path] ;#must do this after file normalize + return [string map [list $matilda ~] $path] ;#get our tildes back. +} +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide modpod [namespace eval modpod { + variable pkg modpod + variable version + set version 0.1.3 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm index 04efdc83..6908f4c3 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm @@ -5192,7 +5192,7 @@ namespace eval punk { #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] - if {[dict get $::punk::config::running auto_exec_mechanism] eq "experimental"} { + if {[punk::config::configure running auto_exec_mechanism] eq "experimental"} { #TODO - something cross-platform that allows us to maintain a separate console(s) with an additional set of IO channels to drive it #not a trivial task @@ -5993,8 +5993,7 @@ namespace eval punk { proc scriptlibpath {{shortname {}} args} { - upvar ::punk::config::running running_config - set scriptlib [dict get $running_config scriptlib] + set scriptlib [punk::config::configure running scriptlib] if {[string match "lib::*" $shortname]} { set relpath [string map [list "lib::" "" "::" "/"] $shortname] set relpath [string trimleft $relpath "/"] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm index 5b45b2bc..c7207cc0 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm @@ -103,7 +103,9 @@ tcl::namespace::eval punk::aliascore { #use absolute ns ie must be prefixed with :: #single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased - #functions must be in export list of their source namespace + #functions should generally be covered by one of the export patterns of their source namespace + # - if they are not - e.g (separately loaded ensemble command ?) + # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. set aliases [tcl::dict::create\ val ::punk::pipe::val\ aliases ::punk::lib::aliases\ @@ -122,8 +124,8 @@ tcl::namespace::eval punk::aliascore { stripansi ::punk::ansi::ansistrip\ ansiwrap ::punk::ansi::ansiwrap\ colour ::punk::console::colour\ - ansi ::punk::console::ansi\ color ::punk::console::colour\ + ansi ::punk::console::ansi\ a? ::punk::console::code_a?\ A? {::punk::console::code_a? forcecolor}\ a+ ::punk::console::code_a+\ @@ -132,6 +134,7 @@ tcl::namespace::eval punk::aliascore { A {::punk::console::code_a forcecolour}\ smcup ::punk::console::enable_alt_screen\ rmcup ::punk::console::disable_alt_screen\ + config ::punk::config\ ] #*** !doctools @@ -153,6 +156,35 @@ tcl::namespace::eval punk::aliascore { # return "ok" #} + proc _is_exported {ns cmd} { + set exports [::tcl::namespace::eval $ns [list namespace export]] + set is_exported 0 + foreach p $exports { + if {[string match $p $cmd]} { + set is_exported 1 + break + } + } + return $is_exported + } + + #_nsprefix accepts entire command - not just an existing namespace for which we want the parent + proc _nsprefix {{nspath {}}} { + #maintenance: from punk::ns::nsprefix - (without unnecessary nstail) + #normalize the common case of :::: + set nspath [string map {:::: ::} $nspath] + set rawprefix [string range $nspath 0 end-[string length [namespace tail $nspath]]] + if {$rawprefix eq "::"} { + return $rawprefix + } else { + if {[string match *:: $rawprefix]} { + return [string range $rawprefix 0 end-2] + } else { + return $rawprefix + } + } + } + #todo - options as to whether we should raise an error if collisions found, undo aliases etc? proc init {args} { set defaults {-force 0} @@ -195,6 +227,7 @@ tcl::namespace::eval punk::aliascore { error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" } + set failed [list] set tempns ::temp_[info cmdcount] ;#temp ns for renames dict for {a cmd} $aliases { #puts "aliascore $a -> $cmd" @@ -206,16 +239,36 @@ tcl::namespace::eval punk::aliascore { } else { if {[tcl::info::commands $cmd] ne ""} { #todo - ensure exported? noclobber? - if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { + set container_ns [_nsprefix $cmd] + set cmdtail [tcl::namespace::tail $cmd] + set was_exported 1 ;#assumption + if {![_is_exported $container_ns $cmdtail]} { + set was_exported 0 + set existing_exports [tcl::namespace::eval $container_ns [list ::namespace export]] + tcl::namespace::eval $container_ns [list ::namespace export $cmdtail] + } + if {[tcl::namespace::tail $a] eq $cmdtail} { #puts stderr "importing $cmd" - tcl::namespace::eval :: [list namespace import $cmd] + try { + tcl::namespace::eval :: [list ::namespace import $cmd] + } trap {} {emsg eopts} { + lappend failed [list alias $a target $cmd errormsg $emsg] + } } else { #target command name differs from exported name #e.g stripansi -> punk::ansi::ansistrip #import and rename #puts stderr "importing $cmd (with rename to ::$a)" - tcl::namespace::eval $tempns [list namespace import $cmd] - catch {rename ${tempns}::[namespace tail $cmd] ::$a} + try { + tcl::namespace::eval $tempns [list ::namespace import $cmd] + } trap {} {emsg eopst} { + lappend failed [list alias $a target $cmd errormsg $emsg] + } + catch {rename ${tempns}::$cmdtail ::$a} + } + #restore original exports + if {!$was_exported} { + tcl::namespace::eval $container_ns [list ::namespace export -clear {*}$existing_exports] } } else { interp alias {} $a {} {*}$cmd @@ -223,7 +276,7 @@ tcl::namespace::eval punk::aliascore { } } #tcl::namespace::delete $tempns - return [dict create aliases [dict keys $aliases] unchanged $ignore_aliases changed $conflicts] + return [dict create aliases [dict keys $aliases] existing $existing ignored $ignore_aliases changed $conflicts failed $failed] } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm index 61a454fa..fcbf6ada 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm @@ -3357,9 +3357,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend PUNKARGS [list { @id -id ::punk::ansi::ansiwrap @cmd -name punk::ansi::ansiwrap -help\ - "Wrap a string with ANSI codes from + {Wrap a string with ANSI codes from supplied codelist(s) followed by trailing - ANSI reset. + ANSI reset. The wrapping is done such that + after every reset in the supplied text, the + default goes back to the supplied codelist. + e.g1 in the following + ansiwrap red bold "rrr[a+ green]ggg[a]rrr" + both strings rrr will be red & bold + + e.g2 bolding and underlining specific text whilst dimming the rest + ansiwrap dim [string map [list test [ansiwrap bold underline test]] "A test string"] + + e.g3 reverse render a complex ansi substring + ansiwrap reverse [textblock::periodic] Codes are numbers or strings as indicated in the output of the colour information @@ -3372,41 +3383,172 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu For finer control use the a+ and a functions eg - set x \"[a+ red]text [a+ bold]etc[a]\" - " + set x "[a+ red]text [a+ bold]etc[a]" + } @leaders -min 0 -max -1 codelist -multiple 1 -default {} -type list -help\ "ANSI names/ints as understood by 'a?' (Not actual ANSI as output by a+) These can be supplied individually or as a list or lists" + @opts + -rawansi -type ansi -default "" + -resetcodes -type list -default {reset} + -rawresets -type ansi -default "" + -fullcodemerge -type boolean -default 0 -help\ + "experimental" + -overridecodes -type list -default {} @values -min 1 -max 1 text -type string -help\ "String to wrap with ANSI (SGR)" }] - #proc ansiwrap {codes text} { - # return [a {*}$codes]$text[a] - #} - proc ansiwrap2 {args} { - set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] - set codelists [dict get $argd leaders codelist] - set text [dict get $argd values text] - set codes [concat {*}$codelists] ;#flatten - return [a {*}$codes]$text[a] - } proc ansiwrap {args} { if {[llength $args] < 1} { - #minimal args parsing - unhappy path only + #throw to args::parse to get friendly error/usage display punk::args::parse $args withid ::punk::ansi::ansiwrap return } - set text [lindex $args end] - set codelists [lrange $args 0 end-1] + #we know there are no valid codes that start with - + if {[lsearch [lrange $args 0 end-1] -*] == -1} { + #no opts + set text [lindex $args end] + set codelists [lrange $args 0 end-1] + set R [a] ;#plain ansi reset + set rawansi "" + set rawresets "" + set fullmerge 0 + set overrides "" + } else { + set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] + lassign [dict values $argd] leaders opts values received solos + set codelists [dict get $leaders codelist] + set text [dict get $values text] + set rawansi [dict get $opts -rawansi] + set R [a+ {*}[dict get $opts -resetcodes]] + set rawresets [dict get $opts -rawresets] + set fullmerge [dict get $opts -fullcodemerge] + set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]] + } + + #note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence. + #there can be SGR unmergeables (due to enhanced underlines) as well as non SGR codes set codes [concat {*}$codelists] ;#flatten - return [a {*}$codes]$text[a] - } + set base [a+ {*}$codes] + if {$rawansi ne ""} { + set rawcodes [punk::ansi::ta::get_codes_single $rawansi] ;#caller may have supplied as [a+ xxx][a+ yyy] + if {$fullmerge} { + set base [punk::ansi::codetype::sgr_merge [list $base {*}$rawcodes]] + } else { + set base [punk::ansi::codetype::sgr_merge_singles [list $base {*}$rawcodes]] + } + } + if {$rawresets ne ""} { + set rawresetcodes [punk::ansi::ta::get_codes_single $rawresets] + if {$fullmerge} { + set R [punk::ansi::codetype::sgr_merge [list $R {*}$rawresetcodes]] + } else { + set R [punk::ansi::codetype::sgr_merge_singles [list $R {*}$rawresetcodes]] + } + } + set codestack [list] + if {[punk::ansi::ta::detect $text]} { + set emit "" + set parts [punk::ansi::ta::split_codes $text] + foreach {pt code} $parts { + switch -- [llength $codestack] { + 0 { + append emit $base$pt$R + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { + append emit $base$pt$R + set codestack [list] + } else { + #append emit [lindex $o_codestack 0]$pt + if {$fullmerge} { + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + } else { + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + } + } + } + default { + if {$fullmerge} { + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + } else { + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + } + } + } + #parts ends on a pt - last code always empty string + if {$code ne ""} { + set c1c2 [tcl::string::range $code 0 1] + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3] + switch -- $leadernorm { + 7CSI - 8CSI { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #todo - make caching is_sgr method + set dup_posns [lsearch -all -exact $codestack $code] + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set o_gx_state on + } + "B" { + set o_gx_state off + } + } + } + default { + #other ansi codes + } + } + append emit $code + } + } + return $emit$R + } else { + return $base$text$R + } + } + proc ansiwrap_naive {codes text} { + return [a_ {*}$codes]$text[a] + } + + #a silly trick... temporary? probably - todo - tests and work on sgr_merge + sgr_merge_singles before relying on this + #when we use sgr_merge_singles on a 'single' containing a non SGR code e.g [5h (inverse) it puts this code at the end of the list + #furthermore - it carries any SGR codes along with it (Can/should we rely on this behaviour??? probably not) REVIEW + #P% ansistring VIEW $s1 + #- ␛[31m␛[?5h + #P% ansistring VIEW [punk::ansi::codetype::sgr_merge_singles [list $s1 [a+ cyan]]] + #- ␛[36m␛[31m␛[?5h + #P% ansistring VIEW [punk::ansi::codetype::sgr_merge [list $s1 [a+ cyan]]] + #- ␛[36m␛[?5h + #we can use this trick to override background and/or foreground colours using ansiwrap - which uses sgr_merge_singles + #Note - this trick is not composable - e.g ansioverride Red [ansiioverride Green [textblock::periodic]] doesn't work as expected. + proc ansioverride2 {args} { + set text [lindex $args end] + set codes [lrange $args 0 end-1] + ansiwrap {*}$codes -rawansi [punk::ansi::enable_inverse] -rawresets [punk::ansi::disable_inverse] $text + } + proc ansireverse {text} { + ansioverride2 normal reverse $text + } proc get_code_name {code} { #*** !doctools @@ -4491,6 +4633,77 @@ tcl::namespace::eval punk::ansi { return 0 } } + + #e.g has_any_effective $str bg fg + proc has_any_effective {str args} { + set singlecodes [punk::ansi::ta::get_codes_single $str] + set mergeinfo [punk::ansi::codetype::sgr_merge_singles $singlecodes -info 1] + foreach t $args { + switch -- $t { + sgr - unmergeable - othercodes { + if {[dict get $mergeinfo $t] ne ""} { + return 1 + } + } + intensity - italic - underline - underextended - blink - reverse - hide - strike - font - gothic - doubleunderline + - proportional - frame_or_circle - ideogram_underline - ideogram_doubleunderline - ideogram_clear - overline - underlinecolour - superscript - subscript + - nosupersub - fg - bg { + if {[dict get $mergeinfo codestate $t] ne ""} { + return 1 + } + } + bold { + if {[dict get $mergeinfo codestate intensity] eq "1"} { + return 1 + } + } + dim { + if {[dict get $mergeinfo codestate intensity] eq "2"} { + return 1 + } + } + default { + error "punk::ansi::ta::has_any_effective invalid type '$t' specified" + } + } + } + return 0 + } + proc has_all_effective {str args} { + set singlecodes [punk::ansi::ta::get_codes_single $str] + set mergeinfo [punk::ansi::codetype::sgr_merge_singles $singlecodes -info 1] + foreach t $args { + switch -- $t { + sgr - unmergeable - othercodes { + if {[dict get $mergeinfo $t] eq ""} { + return 0 + } + } + intensity - italic - underline - underextended - blink - reverse - hide - strike - font - gothic - doubleunderline + - proportional - frame_or_circle - ideogram_underline - ideogram_doubleunderline - ideogram_clear - overline - underlinecolour - superscript - subscript + - nosupersub - fg - bg { + if {[dict get $mergeinfo codestate $t] eq ""} { + return 0 + } + } + bold { + if {[dict get $mergeinfo codestate intensity] ne "1"} { + return 0 + } + } + dim { + if {[dict get $mergeinfo codestate intensity] ne "2"} { + return 0 + } + } + default { + error "punk::ansi::ta::has_any_effective invalid type '$t' specified" + } + } + } + return 1 + } + proc is_gx {code} { #g0 {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} #g1 {(?:\x1b\)0)(?:(?!\x1b\)B).)*\x1b\)B} @@ -4513,6 +4726,7 @@ tcl::namespace::eval punk::ansi { set codestate_empty [tcl::dict::create] tcl::dict::set codestate_empty rst "" ;#0 (or empty) tcl::dict::set codestate_empty intensity "" ;#1 bold, 2 dim, 22 normal + tcl::dict::set codestate_empty shadowed "" ; tcl::dict::set codestate_empty italic "" ;#3 on 23 off tcl::dict::set codestate_empty underline "" ;#4 on 24 off diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.4.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.4.tm index 95d5c702..e1256fe4 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.4.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.4.tm @@ -3226,7 +3226,36 @@ tcl::namespace::eval punk::args { form1: parse $arglist ?-flag val?... withid $id form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define" + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " @form -form {withid withdef} @leaders -min 1 -max 1 arglist -type list -optional 0 -help\ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm index 0dc1a37f..42b97126 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm @@ -750,26 +750,6 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ############################################################################################################################################################ - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::lrange - @cmd -name "builtin: lrange" -help\ - "return one or more adjacent elements from a list. - The new list returned consists of elements first through last, inclusive. - The index values first and last are interpreted the same as index values - for the command 'string index', supporting simple index arithmetic and - indices relative to the end of the list. - e.g lrange {a b c} 0 end-1 - " - @values -min 3 -max 3 - list -type list -help\ - "tcl list as a value" - first -help\ - "index expression for first element" - last -help\ - "index expression for last element" - } "@doc -name Manpage: -url [manpage_tcl lrange]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -802,26 +782,60 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { - @id -id ::lremove - @cmd -name "builtin: lremove" -help\ - "Remove elements from a list by index - lremove returns a new list formed by simultaneously removing zero or - more elements of list at each of the indices given by an arbitrary - number of index arguments. The indices may be in any order and may be - repeated; the element at index will only be removed once. The index - values are interpreted the same as index values for the command - 'string index', supporting simple index arithmetic and indices relative - to the end of the list. 0 refers to the first element of the list, and - end refers to the last element of the list." + @id -id ::lindex + @cmd -name "builtin: lindex" -help\ + "Retrieve an element from a list + " @values -min 1 -max -1 list -type list -help\ "tcl list as a value" - index -type indexexpression -multiple 1 -optional 1 + index -type indexexpression -multiple 1 -optional 1 -help\ + "When no index is supplied or a single index is supplied as an empty list, + the value of the entire list is simply returned. + + If a single index is supplied and is a list of indices - this list is used + as a sequence of nested indices. + The command, + lindex $a 1 2 3 + or + lindex $l {1 2 3} + is synonymous with + lindex [lindex [lindex $a 1] 2] 3 + + When presented with a single indes, the lindex command treats list as a Tcl list + and returns the index'th element from it (0 refers to the first element of the + list). In extracting the element, lindex observes the same rules concerning + braces and quotes and backslashes as the Tcl command interpreter; however, + variable substution and command substitution do not occur. If index is negative + or greater than or equal to the number of elements in 'list', then an empty + string is returned. The interpretation of each simple index value is the same + as for the command 'string index', supporting simple index arithmetic and + indices relative to the end of the list. - @seealso -commands {list lappend lassign ledit lindex linsert llength lmap lpop lrange lrepeat lreplace lreverse lsearch lseq lset lsort} - } "@doc -name Manpage: -url [manpage_tcl lremove]" + If additional index arguments are supplied, then each argument is used in turn + to select an element from the previous indexing operation, allowing the script + to select elements from sublists." + } "@doc -name Manpage: -url [manpage_tcl lindex]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::list + @cmd -name "builtin: list" -help\ + "Create a list + + This command returns a list comprised of all the args, or an empty string + if no args are specified. Braces and backslashes get added as necessary, + so that the lindex command may be used on the result to re-extract the + original arguments, and also so that eval may be used to execute the + resulting list, with arg1 comprising the command's name and the other args + comprising its arguments. List produces slightly different results than + concat: concat removes one level of grouping before forming the list, + while list works directly from the original arguments." + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl list]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lpop @@ -842,6 +856,51 @@ tcl::namespace::eval punk::args::tclcore { previous indexing operation, allowing the script to remove elements in sublists, similar to lindex and lset." } "@doc -name Manpage: -url [manpage_tcl lpop]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lrange + @cmd -name "builtin: lrange" -help\ + "return one or more adjacent elements from a list. + The new list returned consists of elements first through last, inclusive. + The index values first and last are interpreted the same as index values + for the command 'string index', supporting simple index arithmetic and + indices relative to the end of the list. + e.g lrange {a b c} 0 end-1 + " + @values -min 3 -max 3 + list -type list -help\ + "tcl list as a value" + first -help\ + "index expression for first element" + last -help\ + "index expression for last element" + } "@doc -name Manpage: -url [manpage_tcl lrange]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lremove + @cmd -name "builtin: lremove" -help\ + "Remove elements from a list by index + lremove returns a new list formed by simultaneously removing zero or + more elements of list at each of the indices given by an arbitrary + number of index arguments. The indices may be in any order and may be + repeated; the element at index will only be removed once. The index + values are interpreted the same as index values for the command + 'string index', supporting simple index arithmetic and indices relative + to the end of the list. 0 refers to the first element of the list, and + end refers to the last element of the list." + @values -min 1 -max -1 + list -type list -help\ + "tcl list as a value" + index -type indexexpression -multiple 1 -optional 1 + + @seealso -commands {list lappend lassign ledit lindex linsert llength lmap lpop lrange lrepeat lreplace lreverse lsearch lseq lset lsort} + } "@doc -name Manpage: -url [manpage_tcl lremove]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lrange diff --git a/src/vfs/_vfscommon.vfs/modules/punk/basictelnet-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/basictelnet-0.1.0.tm index b510df36..623fe28e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/basictelnet-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/basictelnet-0.1.0.tm @@ -478,6 +478,13 @@ namespace eval punk::basictelnet { set tmode [dict get $argd opts -mode] set mouse [dict get $argd opts -mouse] + if {[info commands ::colour] ne ""} { + #The ansiwrap filter on stdout/stderr slows rendering significantly e.g on max headroom ansi vid at server: 1984.ws + #TODO - just disable the channel filters - not all ansi colour. + set priorcolourstate [::colour] + ::colour off + } + #todo - check for vt52 and don't try DEC queries if {[info commands ::mode] eq ""} { puts stderr "::mode command for terminal is unavailable - please set line/raw mode manually on the terminal" @@ -540,6 +547,12 @@ namespace eval punk::basictelnet { vwait ::punk::basictelnet::closed($sock) unset closed($sock) chan conf stdin -blocking 1 + + + if {[info commands ::colour] ne ""} { + ::colour $priorcolourstate + } + if {[info commands ::mode] ne ""} { ::mode $priormode } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm index 5532cb80..e278d99f 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm @@ -1,23 +1,109 @@ tcl::namespace::eval punk::config { - variable loaded - variable startup ;#include env overrides - variable running + variable configdata [dict create] ;#key on config names. At least default, startup, running + + #variable startup ;#include env overrides + #variable running + variable punk_env_vars variable other_env_vars variable vars namespace export {[a-z]*} + namespace ensemble create + namespace eval punk {namespace export config} + + proc _homedir {} { + if {[info exists ::env(HOME)]} { + set home [file normalize $::env(HOME)] + } else { + #not available on 8.6? ok will error out here. + set home [file tildeexpand ~] + } + return $home + } + + lappend PUNKARGS [list { + @id -id ::punk::config::dir + @cmd -name punk::config::dir -help\ + "Get the path for the default config folder + Config files are in toml format. + + The XDG_CONFIG_HOME env var is the preferred + choice of location. + A folder under the user's home directory, + at .config/punk/shell is chosen if + XDG_CONFIG_HOME is not configured. + " + @leaders -min 0 -max 0 + @opts + -quiet -type none -help\ + "Suppress warning given when the folder does + not yet exist" + @values -min 0 -max 0 + }] + proc dir {args} { + if {"-quiet" in $args} { + set be_quiet [dict exists $received -quiet] + } + + set was_noisy 0 + + set config_home [punk::config::configure running xdg_config_home] + + set config_dir [file join $config_home punk shell] + + if {!$be_quiet && ![file exists $config_dir]} { + set msg "punk::shell data storage folder at $config_dir does not yet exist." + puts stderr $msg + set was_noisy 1 + } + + if {!$be_quiet && $was_noisy} { + puts stderr "punk::config::dir - call with -quiet option to suppress these messages" + } + return $config_dir + + #if {[info exists ::env(XDG_CONFIG_HOME)]} { + # set config_home $::env(XDG_CONFIG_HOME) + #} else { + # set config_home [file join [_homedir] .config] + # if {!$be_quiet} { + # puts stderr "Environment variable XDG_CONFIG_HOME does not exist - consider setting it if $config_home is not a suitable location" + # set was_noisy 1 + # } + #} + #if {!$be_quiet && ![file exists $config_home]} { + # #parent folder for 'punk' config dir doesn't exist + # set msg "configuration location (XDG_CONFIG_HOME or ~/.config) $config_home does not yet exist" + # append msg \n " - please create it and/or set XDG_CONFIG_HOME env var." + # puts stderr $msg + # set was_noisy 1 + #} + #set config_dir [file join $config_home punk shell] + #if {!$be_quiet && ![file exists $config_dir]} { + # set msg "punk::shell data storage folder at $config_dir does not yet exist." + # append msg \n " It will be created if api_context_save is called without specifying an alternate location." + # puts stderr $msg + # set was_noisy 1 + #} + #if {!$be_quiet && $was_noisy} { + # puts stderr "punk::config::dir - call with -quiet option to suppress these messages" + #} + #return [file join $configdir config.toml] + } #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 configdata + + #variable defaults + #variable startup + #variable running variable punk_env_vars variable punk_env_vars_config variable other_env_vars @@ -108,12 +194,14 @@ tcl::namespace::eval punk::config { #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)]} { + #Typical existing/default value for env(APPDATA) on windows is c:\Users\\AppData\Roaming 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)]} { + #Typical existing/default value for env(APPDATA) on windows is c:\Users\\AppData\Local + set default_xdg_data_home $::env(LOCALAPPDATA) set default_xdg_cache_home $::env(LOCALAPPDATA) set default_xdg_state_home $::env(LOCALAPPDATA) } @@ -133,10 +221,10 @@ tcl::namespace::eval punk::config { } } - set defaults [dict create\ + dict set configdata defaults [dict create\ apps $default_apps\ - config ""\ - configset ".punkshell"\ + config "startup"\ + configset "main"\ scriptlib $default_scriptlib\ color_stdout $default_color_stdout\ color_stdout_repl $default_color_stdout_repl\ @@ -160,7 +248,7 @@ tcl::namespace::eval punk::config { posh_themes_path ""\ ] - set startup $defaults + dict set configdata startup [dict get $configdata 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 @@ -219,9 +307,9 @@ tcl::namespace::eval punk::config { lappend final $p } } - tcl::dict::set startup $varname $final + tcl::dict::set configdata startup $varname $final } else { - tcl::dict::set startup $varname $f + tcl::dict::set configdata startup $varname $f } } } @@ -273,29 +361,46 @@ tcl::namespace::eval punk::config { lappend final $p } } - tcl::dict::set startup $varname $final + tcl::dict::set configdata startup $varname $final } else { - tcl::dict::set startup $varname $f + tcl::dict::set configdata startup $varname $f } } } } + set config_home [dict get $configdata startup xdg_config_home] + + if {![file exists $config_home]} { + puts stderr "punk::config::init creating punk shell config dir: $config_home" + if {[catch {file mkdir $config_home} errM]} { + puts stderr "punk::config::init failed to create dir at $config_home\n$errM" + } + } + + set configset [dict get $configdata defaults configset] + set config [dict get $configdata defaults config] + + set startupfile [file join $config_home $configset $config.toml] + if {![file exists $startupfile]} { + puts stderr "punk::config::init creating punk shell config file: $config for configset: $configset" + puts stderr "(todo)" + } #unset -nocomplain vars #todo set running [tcl::dict::create] - set running [tcl::dict::merge $running $startup] + dict set configdata running [tcl::dict::merge $running [dict get $configdata startup]] } - init #todo proc Apply {config} { + variable configdata puts stderr "punk::config::Apply partially implemented" set configname [string map {-config ""} $config] if {$configname in {startup running}} { - upvar ::punk::config::$configname applyconfig + set applyconfig [dict get $configdata $configname] if {[dict exists $applyconfig auto_noexec]} { set auto [dict get $applyconfig auto_noexec] @@ -315,67 +420,128 @@ tcl::namespace::eval punk::config { } return "apply done" } - Apply startup #todo - consider how to divide up settings, categories, 'devices', decks etc proc get_running_global {varname} { - variable running + variable configdata + set running [dict get $configdata 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 + variable configdata + set startup [dict get $configdata 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 + lappend PUNKARGS [list { + @id -id ::punk::config::get + @cmd -name punk::config::get -help\ + "Get configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + whichconfig -type string -choices {config startup-configuration running-configuration} + @values -min 0 -max -1 + globkey -type string -default * -optional 1 -multiple 1 + }] + proc get {args} { + set argd [punk::args::parse $args withid ::punk::config::get] + lassign [dict values $argd] leaders opts values received solos + set whichconfig [dict get $leaders whichconfig] + set globs [dict get $values globkey] ;#list + + variable configdata + switch -- $whichconfig { - config - startup - startup-config - startup-configuration { + config - startup-configuration { + #review 'config' ?? #show *startup* config - different behaviour may be confusing to those used to router startup and running configs - set configdata $startup + set configrecords [dict get $configdata startup] } - running - running-config - running-configuration { - set configdata $running + running-configuration { + set configrecords [dict get $configdata running] } default { error "Unknown config name '$whichconfig' - try startup or running" } } - if {$globfor eq "*"} { - return $configdata + if {"*" in $globs} { + return $configrecords } else { - set keys [dict keys $configdata [string tolower $globfor]] + set keys [list] + foreach g $globs { + lappend keys {*}[dict keys $configrecords [string tolower $g]] ;#review tolower? + } + set filtered [dict create] foreach k $keys { - dict set filtered $k [dict get $configdata $k] + dict set filtered $k [dict get $configrecords $k] } return $filtered } } + lappend PUNKARGS [list { + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ + "Get/set configuration values from a config" + @leaders -min 1 -max 1 + whichconfig -type string -choices {defaults startup-configuration running-configuration} + @values -min 0 -max 2 + key -type string -optional 1 + newvalue -optional 1 + }] 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::parse $args withid ::punk::config::configure] + lassign [dict values $argd] leaders opts values received solos + set whichconfig [dict get $argd leaders whichconfig] + variable configdata + if {"running" ni [dict keys $configdata]} { + init + Apply startup } - set argd [punk::args::get_dict $argdef $args] - return "unimplemented - $argd" + switch -- $whichconfig { + defaults { + set configrecords [dict get $configdata defaults] + } + startup-configuration { + set configrecords [dict get $configdata startup] + } + running-configuration { + set configrecords [dict get $configdata running] + } + } + if {![dict exists $received key]} { + return $configrecords + } + set key [dict get $values key] + if {![dict exists $received newvalue]} { + return [dict get $configrecords $key] + } + error "setting value not implemented" } - proc show {whichconfig {globfor *}} { + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::config::show + @cmd -name punk::config::get -help\ + "Display configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + }\ + {${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ + "@values -min 0 -max -1"\ + {${[punk::args::resolved_def -types values ::punk::config::get]}}\ + ] + proc show {args} { #todo - tables for console - set configdata [punk::config::get $whichconfig $globfor] - return [punk::lib::showdict $configdata] + set configrecords [punk::config::get {*}$args] + return [punk::lib::showdict $configrecords] } @@ -459,27 +625,35 @@ tcl::namespace::eval punk::config { ::tcl::namespace::eval punk::config { #todo - something better - 'previous' rather than reverting to startup proc channelcolors {{onoff {}}} { - variable running - variable startup + variable configdata + #variable running + #variable startup if {![string length $onoff]} { - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + return [list stdout [dict get $configdata running color_stdout] stderr [dict get $configdata 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] + dict set configdata running color_stdout [dict get $startup color_stdout] + dict set configdata running color_stderr [dict get $startup color_stderr] } else { - dict set running color_stdout "" - dict set running color_stderr "" + dict set configdata running color_stdout "" + dict set configdata running color_stderr "" } } - return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] + return [list stdout [dict get $configdata running color_stdout] stderr [dict get $configdata running color_stderr]] } + } +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::config +} + + package provide punk::config [tcl::namespace::eval punk::config { variable version set version 0.1 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm index a3f5d95c..19d9d7e4 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm @@ -584,10 +584,10 @@ namespace eval punk::console { channel's response to a query placed on the output channel. Usually this means a write to stdout with a response on stdin. - This function uses a 'chan event' read handler function + This function uses a 'chan event' read handler function ::punk::console::internal::ansi_response_handler_regex to read the input channel character by character to ensure it - doesn't overconsume input. + doesn't overconsume input. It can run cooperatively with the punk::repl stdin reader or other readers if done carefully. @@ -609,7 +609,7 @@ namespace eval punk::console { "dict with keys prefix,response,payload,all" } -help\ "Return format" - + -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" -expected_ms -default 100 -type integer -help\ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mod-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mod-0.1.tm index 26ed2f2e..8f1ba266 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mod-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mod-0.1.tm @@ -33,8 +33,7 @@ namespace eval punk::mod::cli { return $basehelp } proc getraw {appname} { - upvar ::punk::config::running running_config - set app_folders [dict get $running_config apps] + set app_folders [punk::config::configure running apps] #todo search each app folder set bases [::list] set versions [::list] @@ -86,8 +85,7 @@ namespace eval punk::mod::cli { } proc list {{glob *}} { - upvar ::punk::config::running running_config - set apps_folder [dict get $running_config apps] + set apps_folder [punk::config::configure running apps] if {[file exists $apps_folder]} { if {[file exists $apps_folder/$glob]} { #tailcall source $apps_folder/$glob/main.tcl diff --git a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm index 74185191..aa0e71de 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm @@ -562,10 +562,19 @@ tcl::namespace::eval punk::netbox { used when an explicit path is not given by the caller to the api_context load/save functions. This file is in toml format. + + On any platform the XDG_DATA_HOME env var + can be used to override the location, but + on Windows the LOCALAPPDATA env var will + specifiy the location if XDG_DATA_HOME is + not set. + Interfacing with a proper secret store + should be considered as an alternative. + + On non Windows platforms: The XDG_DATA_HOME env var is the preferred - choice of location - considered more secure - than XDG_CONFIG_HOME, although not as good - as a proper secret store. + choice of location - considered slightly more + secure than XDG_CONFIG_HOME. A folder under the user's home directory, at .local/share/punk/netbox is chosen if XDG_DATA_HOME is not configured. @@ -586,16 +595,20 @@ tcl::namespace::eval punk::netbox { if {[info exists ::env(XDG_DATA_HOME)]} { set data_home $::env(XDG_DATA_HOME) } else { - set data_home [file join [_homedir] .local share] - if {!$be_quiet} { - puts stderr "Environment variable XDG_DATA_HOME does not exist - consider setting it if $data_home is not a suitable location" - set was_noisy 1 + if {$::tcl_platform(platform) eq "windows"} { + set data_home $::env(LOCALAPPDATA) + } else { + set data_home [file join [_homedir] .local share] + if {!$be_quiet} { + puts stderr "Environment variable XDG_DATA_HOME does not exist - consider setting it if $data_home is not a suitable location" + set was_noisy 1 + } } } if {!$be_quiet && ![file exists $data_home]} { #parent folder for 'punk' config dir doesn't exist - set msg "configuration location (XDG_DATA_HOME or ~/.local/share) $data_home does not yet exist" - append msg \n " - please create it and/or set XDG_DATA_HOME env var." + set msg "configuration location XDG_DATA_HOME or ~/.local/share (or LOCALAPPDATA on windows) at path '$data_home' does not yet exist" + append msg \n " - please create it and/or set the appropriate env var." puts stderr $msg set was_noisy 1 } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm index 4eb6526d..b89bc021 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm @@ -375,7 +375,9 @@ tcl::namespace::eval punk::ns { #This is because :x (or even just : ) can in theory be the name of a command and we may need to see it (although it is not a good idea) #and a namespace can exist with leading colon - but is even worse - as default Tcl commands will misreport e.g namespace current within namespace eval #The view is taken that a namespace with leading/trailing colons is so error-prone that even introspection is unreliable so we will rule that out. - # + # + #nsprefix is *somewhat* like 'namespace parent' execept that it is string based - ie no requirement for the namespaces to actually exist + # - this is an important usecase even if the handling of 'unwise' command names isn't so critical. proc nsprefix {{nspath ""}} { #normalize the common case of :::: set nspath [string map {:::: ::} $nspath] @@ -394,10 +396,12 @@ tcl::namespace::eval punk::ns { #namespace tail which handles :::cmd ::x:::y ::x:::/y etc in a specific manner for string processing #review - consider making -strict raise an error for unexpected sequences such as :::: or any situation with more than 2 colons together. + #This is only necessary in the context of requirement to browse namespaces with 'unwisely' named commands + #For most purposes 'namespace tail' is fine. proc nstail {nspath args} { #normalize the common case of :::: set nspath [string map {:::: ::} $nspath] - set mapped [string map {:: \u0FFF} $nspath] + set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] set defaults [list -strict 0] @@ -2018,7 +2022,7 @@ tcl::namespace::eval punk::ns { } proc arginfo {args} { lassign [dict values [punk::args::parse $args withid ::punk::ns::arginfo]] leaders opts values received - + set nscaller [uplevel 1 [list ::namespace current]] #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. if {![dict exists $received -scheme]} { @@ -2081,16 +2085,18 @@ tcl::namespace::eval punk::ns { } } else { #namespace as relative to current doesn't seem to exist - #Tcl would also attempt to resolve as global + #Tcl would also attempt to resolve as global - #set numvals [expr {[llength $queryargs]+1}] + #set numvals [expr {[llength $queryargs]+1}] ##puts "THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]] - return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] + if {$nscaller ne "::"} { + return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] + } + + set origin $querycommand + set resolved $querycommand - #set origin $querycommand - #set resolved $querycommand - } } } @@ -2098,7 +2104,7 @@ tcl::namespace::eval punk::ns { #check for a direct match first if {[info commands ::punk::args::id_exists] ne ""} { if {![llength $queryargs]} { - punk::args::update_definitions [list [namespace qualifiers $origin]] + punk::args::update_definitions [list [namespace qualifiers $origin]] if {[punk::args::id_exists $origin]} { return [uplevel 1 [list punk::args::usage {*}$opts $origin]] } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm index d08cb8cb..a99a7805 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm @@ -1722,7 +1722,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config # --- variable reading variable id_outstack - upvar ::punk::config::running running_config + #upvar ::punk::config::configdata configd + #set running_config [dict get $configd running] try { #catch {puts stderr "xx--->[rep $::arglej]"} @@ -2794,21 +2795,28 @@ namespace eval repl { interp eval code [list apply {docolour { #adjust channel transform stack if {!$docolour} { - set s [lindex $::codeinterp::outstack end] - if {$s ne ""} { - shellfilter::stack::remove stdout $s + set stackinfo [dict get [shellfilter::stack item stdout] stack] + set topstack [lindex $stackinfo 0] + if {[string match *::ansiwrap [dict get $topstack -transform]]} { + set sid [dict get $topstack -id] + shellfilter::stack::remove stdout $sid } - set s [lindex $::codeinterp::errstack end] - if {$s ne ""} { - shellfilter::stack::remove stderr $s + set stackinfo [dict get [shellfilter::stack item stderr] stack] + set topstack [lindex $stackinfo 0] + if {[string match *::ansiwrap [dict get $topstack -transform]]} { + set sid [dict get $topstack -id] + shellfilter::stack::remove stderr $sid } + } else { - set running_config $::punk::config::running - if {[string length [dict get $running_config color_stdout]]} { - lappend ::codeinterp::outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]] + set configd $::punk::config::configdata + if {[string length [dict get $configd running color_stdout]]} { + #lappend ::codeinterp::outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]] + shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $configd running color_stdout]] } - if {[string length [dict get $running_config color_stderr]]} { - lappend ::codeinterp::errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] + if {[string length [dict get $configd running color_stderr]]} { + #lappend ::codeinterp::errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] + shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $configd running color_stderr]] } } @@ -3273,12 +3281,12 @@ namespace eval repl { package require shellfilter ;#requires: shellthread,Thread apply {running_config { if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} { - lappend ::codeinterp::errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] + shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]] } if {[string length [dict get $running_config color_stdout]] && [punk::console::colour]} { - lappend ::codeinterp::outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]] + shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]] } - }} $::punk::config::running + }} [punk::config::configure running] } errM]} { puts stderr "========================" @@ -3352,6 +3360,7 @@ namespace eval repl { #puts stderr ----- if {[catch { + package require punk::args package require punk::config package require punk::ns #puts stderr "loading natsort" @@ -3360,19 +3369,19 @@ namespace eval repl { package require natsort #catch {package require packageTrace} package require punk - package require punk::args + #package require punk::args package require punk::args::tclcore package require shellrun package require shellfilter #set running_config $::punk::config::running apply {running_config { if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} { - lappend ::codeinterp::errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]] + shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]] } if {[string length [dict get $running_config color_stdout]] && [punk::console::colour]} { - lappend ::codeinterp::outstack [shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]]] + shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout]] } - }} $::punk::config::running + }} [punk::config::configure running] package require textblock } errM]} { @@ -3393,6 +3402,7 @@ namespace eval repl { code alias quit ::repl::interphelpers::quit code alias editbuf ::repl::interphelpers::editbuf code alias colour ::repl::interphelpers::colour + code alias color ::repl::interphelpers::colour code alias mode ::repl::interphelpers::mode code alias vt52 ::repl::interphelpers::vt52 #code alias after ::repl::interphelpers::do_after diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm index a64eef0f..7bf8306e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm @@ -175,13 +175,13 @@ tcl::namespace::eval punk::repl::codethread { set outstack [list] set errstack [list] - upvar ::punk::config::running running_config - if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { + set config_running [::punk::config::configure running] + if {[string length [dict get $config_running color_stdout_repl]] && [interp eval code punk::console::colour]} { lappend outstack [interp eval code [list ::shellfilter::stack add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] } lappend outstack [interp eval code [list ::shellfilter::stack add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] - if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { + if {[string length [dict get $config_running color_stderr_repl]] && [interp eval code punk::console::colour]} { lappend errstack [interp eval code [list ::shellfilter::stack add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] # #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] } diff --git a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm index 92b214d8..73ea752c 100644 --- a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm +++ b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm @@ -674,6 +674,9 @@ namespace eval shellfilter::chan { #todo - track when in sixel,iterm,kitty graphics data - can be very large method Trackcodes {chunk} { + #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) + #e.g [a+ reset reset] (0;0m vs 0;m) + #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" set buf $o_buffered$chunk set emit "" @@ -686,12 +689,29 @@ namespace eval shellfilter::chan { #process all pt/code pairs except for trailing pt foreach {pt code} [lrange $parts 0 end-1] { #puts "<==[ansistring VIEW -lf 1 $pt]==>" - if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - append emit $o_do_colour$pt$o_do_normal - #append emit $pt - } else { - append emit $pt + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$pt + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt + } } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # append emit $o_do_colour$pt$o_do_normal + # #append emit $pt + #} else { + # append emit $pt + #} set c1c2 [tcl::string::range $code 0 1] set leadernorm [tcl::string::range [tcl::string::map [list\ @@ -732,7 +752,7 @@ namespace eval shellfilter::chan { } - set trailing_pt [lindex $parts end] + set trailing_pt [lindex $parts end] if {[string first \x1b $trailing_pt] >= 0} { #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" #may not be plaintext after all @@ -740,15 +760,32 @@ namespace eval shellfilter::chan { #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" } else { #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] - if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { - append emit $o_do_colour$trailing_pt$o_do_normal - } else { - append emit $trailing_pt + switch -- [llength $o_codestack] { + 0 { + append emit $o_do_colour$trailing_pt$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + append emit $o_do_colour$trailing_pt$o_do_normal + set o_codestack [list] + } else { + #append emit [lindex $o_codestack 0]$trailing_pt + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt + } + } + default { + append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt + } } + #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { + # append emit $o_do_colour$trailing_pt$o_do_normal + #} else { + # append emit $trailing_pt + #} #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext set o_buffered "" } - + } else { #REVIEW - this holding a buffer without emitting as we go is ugly. @@ -759,11 +796,14 @@ namespace eval shellfilter::chan { #puts "-->esc but no detect" #no complete ansi codes - but at least one esc is present - if {[string last \x1b $buf] == [string length $buf]-1} { - #only esc is last char in buf + if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { + #string index in first part of && clause to avoid some unneeded scans of whole string for this test + #we can't use 'string last' - as we need to know only esc is last char in buf #puts ">>trailing-esc<<" set o_buffered \x1b - set emit [string range $buf 0 end-1] + set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal + #set emit [string range $buf 0 end-1] + set buf "" } else { set emit_anyway 0 #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer @@ -774,15 +814,18 @@ namespace eval shellfilter::chan { if {$st_partial_len < 1001} { append o_buffered $chunk set emit "" + set buf "" } else { set emit_anyway 1 - } + set o_buffered "" + } } else { set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code #most opening sequences are 1,2 or 3 chars - review? set open_sequence_detected [punk::ansi::ta::detect_open $buf] if {$possible_code_len > 10 && !$open_sequence_detected} { set emit_anyway 1 + set o_buffered "" } else { #could be composite sequence with params - allow some reasonable max sequence length #todo - configurable max sequence length @@ -790,39 +833,74 @@ namespace eval shellfilter::chan { # - allow some headroom for redundant codes when the caller didn't merge. if {$possible_code_len < 101} { append o_buffered $chunk + set buf "" set emit "" } else { #allow a little more grace if we at least have an opening ansi sequence of any type.. if {$open_sequence_detected && $possible_code_len < 151} { append o_buffered $chunk + set buf "" set emit "" } else { set emit_anyway 1 + set o_buffered "" } } } } if {$emit_anyway} { - #looked ansi-like - but we've given enough length without detecting close.. + #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. + + #looked ansi-like - but we've given enough length without detecting close.. #treat as possible plain text with some esc or unrecognised ansi sequence - if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - set emit $o_do_colour$buf$o_do_normal - } else { - set emit $buf + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } } + #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { + # set emit $o_do_colour$buf$o_do_normal + #} else { + # set emit $buf + #} } } - } + } } else { #no esc #puts stdout [a+ yellow]...[a] #test! - if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - set emit $o_do_colour$buf$o_do_normal - } else { - set emit $buf + switch -- [llength $o_codestack] { + 0 { + set emit $o_do_colour$buf$o_do_normal + } + 1 { + if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { + set emit $o_do_colour$buf$o_do_normal + set o_codestack [list] + } else { + #set emit [lindex $o_codestack 0]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } + } + default { + #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf + set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf + } } - #set emit $buf set o_buffered "" } return [dict create emit $emit stacksize [llength $o_codestack]] @@ -849,20 +927,29 @@ namespace eval shellfilter::chan { #puts stdout "" set emit [tcl::encoding::convertto $o_enc $o_buffered] set o_buffered "" - return $emit + return $emit return } method write {transform_handle bytes} { set instring [tcl::encoding::convertfrom $o_enc $bytes] set streaminfo [my Trackcodes $instring] set emit [dict get $streaminfo emit] - if {[dict get $streaminfo stacksize] == 0} { - #no ansi on the stack - we can wrap - #review - set outstring "$o_do_colour$emit$o_do_normal" - } else { - set outstring $emit - } + + #review - wrapping already done in Trackcodes + #if {[dict get $streaminfo stacksize] == 0} { + # #no ansi on the stack - we can wrap + # #review + # set outstring "$o_do_colour$emit$o_do_normal" + #} else { + #} + #if {[llength $o_codestack]} { + # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit + #} else { + # set outstring $emit + #} + + set outstring $emit + #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" return [tcl::encoding::convertto $o_enc $outstring] @@ -2260,7 +2347,7 @@ namespace eval shellfilter { # if {!$is_script} { set experiment 0 - if $experiment { + if {$experiment} { try { set results [exec {*}$commandlist] set exitinfo [list exitcode 0] diff --git a/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm index bb820f68..8365c100 100644 --- a/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm @@ -21,12 +21,12 @@ namespace eval shellrun { #some ugly coupling with punk/punk::config for now #todo - something better - if {[info exists ::punk::config::running]} { - upvar ::punk::config::running conf - set syslog_stdout [dict get $conf syslog_stdout] - set syslog_stderr [dict get $conf syslog_stderr] - set logfile_stdout [dict get $conf logfile_stdout] - set logfile_stderr [dict get $conf logfile_stderr] + if {[info exists ::punk::config::configdata]} { + set conf_running [punk::config::configure running] + set syslog_stdout [dict get $conf_running syslog_stdout] + set syslog_stderr [dict get $conf_running syslog_stderr] + set logfile_stdout [dict get $conf_running logfile_stdout] + set logfile_stderr [dict get $conf_running logfile_stderr] } else { lassign [list "" "" "" ""] syslog_stdout syslog_stderr logfile_stdout logfile_stderr } diff --git a/src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.5.tm b/src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.5.tm index 35de5e704f3c9f66b7648340e6298f248a15f998..3ae60d426cf6b63988005e9d06eb1aac81a2c04f 100644 GIT binary patch delta 8502 zcmZWu1ymecwxt^h?oM!T+}#PDpuq_eT!TA}BtURdc!Ik-L4vzWu;5OD2X{V?mzjC< zr+cm2d+)RFsjhpg`a3osB80xyU#054cvKpY#hdKwml4;xXFR6R#j z4Tnxzo}ini6yQdU4Flt(2P`M^0Apl~P#cGNxr966dp!6bDD-HGR*YOh0R%nvyuXLw zK1Y#6k%++RVJevFm?%|oGpkj}j6s)g3fAVm_#Fi!YXfQ2VqJG#cNSy~j*aM=g#=Wo zR38Qcr9V!hsGCg$1!>C+w7sUC)DK=e#SL#Ta-~>NU%-^+O3m>=(GnH83phv`gwn*U zW6~^)#w9{p*#uK}@RVg^qe`W33F9RVmGJWpmd-$TA%P#*)U76HP9~UDvvFS-@yS%a zq9Q_gNU-vs`1$5J=Ba-7n3OM5-0uygE6JV~#2^h?_JVHQmRXLjHN)g!(J+0;sTp=5 zzd`utZ{7w!4S8{7>y{TQ&lAUPZlR4NfhnimJB`#16Q5lch_-Otrjsu`wcq{5fD*cU z`E9OcaBfv~X~-HI<*m*635Ybmbm8tWTtiGD(X@W=#H-G(CKNAQr>4F~INeIaHKm!w zQmBw>R+!nNtDvfq%U_Sj^o;;Nu)IuhP+!MBwc9TRt~yrlG7Ao0H8@Yb@GBG_!o7pl zal3M^N$YAwvR%qrCJ^A~dVbrcNS@T3vS-tH_KL;$_%`!$v=g4fzNmVP04Ij&1JW9j zZLG$qB###55+nx;U4x1pz6Xmu5X-fqSv3y2F@J;PMP)EDd8Epdd1w1jbWgy&t3_;I z5^7KgX3gE-{h-iO5um77=LB7>MJ`TE7_jP8`!Ut6OuhuYZqhbrzDmc~HrdpKZM*w@ zJA-j3mKJ`5?{|AGUm_>y19f+Fb-h1;jy^DIGTjn*V{BTOoc-E4zUyuM=-H~o}P{k`v>Tmv)@~=W%Kh-*I9079VK@=?9DKjhMNYQbSKVDp_$^1zUu>TUh8(h0jzH(k^8Au=i{&5#ib+4}OjGZ)i88Y6g9z<> zw~Wch)>j8qJjD?Nlh!rf%G!628l(0!Fev3j6KI*@X$aY$b-An4 zVggEcx6JbkDmCX5%IBNffqO8Trtjc@Z8sM4^CO44s>7|4%&6(9lFS1}pJg$cdw#-- zK(sKaB>i~9Rf zgumzH=vx$IaN?Vi=8r3wUptKUzT@Jj}^bUif@l`g8 z?doxrZLc0~{xA};P0_hGB5(gtU@g^2j7N5SodsF()PXZ*$a5-#t42UDwz5CMPipoS z{BUx4l+Dybr2i@(qO+350RAeJZh9&KA1SfpCyNziU3y1+(sisl9KR#7O19gX9zbZT zdX9TYSQ#FmAf|PRf70zhP>~5G_PMS?oM5bnbxdT9@yI_U&)plGGvW(X=n-b{eP=M; z@i5XahK!o_GxB+Q_3K)RRKM5K8qZpudD>?yA;k8ZLyVE_K-dN^f-1tYm&qibhmr_U zU~P&7{o(`R>?*;?6Dh{m%i<_{l2WcJa#Q2I?}K0+nQFWY$ydYFJ1VT-V+V)pO z;m|)2iFNkaY*b~Tn-eH*{1D=*b$)bjtHQ$2c1RnB-m>@uK}U-MPl@Ta=O|=Q9S>`} zL)8CJf~qGo7^_8F2^RSpdW8_=HFi9h;_J?Xh8he)v0YF+P7rs&IC)>F+qj8(%xm>j0wFk+# zMQMn?Zl0erY;~Hx-6D>mf+rJeKMnV!AYGq*%k(q91t(t!1fy`52hAm&;7A}RWaBC@ zQSRn`X|Z)WRgA=Jhw#be6j^o}%}hAcq1@=keBj&lAo&Bcpo1~E1S+}Zj!7cULoeEg z8MDFG6va-YlFG(A>EUzUx0`&FmUe`$zHc)t6kCVH91^$C=T{WK!2!k)a#%C-Lk}x7 zuNRr+cg`dBXdrGgh8|HJM9YypFM3wM_Tq-{7NUW5<@GII4%0zq_I)2EC+b;8Xzoa; zl#YDok}=BI7fi$P;9g15XcjN0KqE9GV(Yt=!R8SueT@-4#KDzo z-u}SJu~m*|5Ku_wPD!|p$WZ)itBe76)fkBn0U;7IBL{lc`OufgM$LUn5RUBL{nB*5 zE0?J|4@a}{(!-XiI&1FR3Rm_7x+4XDM-RsMcQT+}2bS0{nj|IA-TEkUHbuaq!tUL= zn2@Yh-xc14g>R)WNt|D+J<`33g(V$CKHe#jAHj0S1H3e+$_j^p(%ptur%5#HjGbtY z-^g}q@hUm1cQ@g)K6GYmS-F+S;ZeYQ1`7h9m~)W0!^D}4aLl~0mr>SAw%rGIE$I$ zvwrJEOy{I5nXG(baW*0YqSR_Y5n|grMp4ddtpJHS#9CVl`yHjN^PH zxUD>qfc#<0JYyI2ttbZLP)R2%!}zAsN4~^Fhx>l6Af#Rso;rdh=(now@(&?Foug7s zfxk!BiJ+?m;S$c;AdhUl_oY7Z9g&x%gx;7TFXY;Zsq7Wf7S#L&@R-`GAqzFgYPX~3 zr|QAQh~eoOGaddc*ZV`}Y1^HM!SeWwam&^(%YWiD0crl7cWNWs}3GC7q8IR+)*5=y&YsYxH;AB?xkJ>x~=5dtem+n>PTws4?0_vNmQGsByf#` zX~9svPPts{5LB}O==8GRjL2+KtD)B0`9*us43k zRnKn{(HKsj=R6_9*&Y`go|uyn>bh5*mV|0CF3y;Ch*q_>hvUqnWcFVSa96EH2eGZ8 zWO0=G&iAASclg_-aW9-k=i`084J+hs8nvg;R;7LDK#|XmGXd3gaioV|_F8JosXk|- zqUkaDhD)(qi2b#H6z)rEm9yhnL{|*UUZPO~ zV`kxFPm^Zx6}Um_{NGEUQx%e5r|B}XS5G9FYad(DvE7Vrd zmAKhw0F^-ihRn~sJG=PbdrH6Wq)<^r^1Uz|)-X)x^1W+EPv9A`CGb9DNZPVUV4-Re zUW&W0OB8li(UzfgW>>nJB0*$bhaSO}tlH$foz)~PkzYBOY|aj{M|IN8=%u|7j$k{U zEf>l_5R}sF+pt(8Vk(p|#(8Cq|jf8+rMl8l>-9ut?fm)**6;wBlihk+qkGN^c8=t3RglN z3iw+r@2PqGDd~OFfg8q34!(=Dd&1<~m-;k5;ub6fCm~o{p%FfTyme( z2a87O-8%uX=RxOWv_0qj=LIn#1~*O?Z_^9wH>4o9oc6@=>R*+F^#{Gh$_R`z}5U}J5T)qBJRZ)IQWf1~2hw63 zl3Zc)O)Ms5BI;FQ^tubDkUra0$nz_kudr@n130orhNt`~;jUlhZTDE5-YjaoCLnO{ zn(UDhC}thW;$TK9L1R-;pM*VBX8x2)gk4o-c*Kn6qmJGe0=4oF1{+>q4R7K#BT>V^ zeIsO2ros}ZUYG6{iZH=1$MF4ef9piHl*Ol{IyPnJJWgIWo%w1ubew01rH5F0W-HA_ zrzg6?zv1VE(Hw16MY2*`Cez3F`%_e37koI-_5%q7f1}AoY@qruJ8IZlZU&XI5y-9p(?`isZF zC}8x~6dKcH-^q^p!W{~~x+k%pQ=Z8%=D;u}F)cnXO(UJ48yf{}O)%|Z5ZuvUjY(v# z4B#ukdl(`_x(@A(fA4Bg*~R;UCMZRcW>JWnC>J5ys9GgcQfXBTQ#R;It{pN}V%)!f+C!`8~)=HcNfAwcRw21s&n01m?# z$WM-khsQ%#hxjxz6a8!7Ornx>UkpF{eFqN%!^Q&xBLR#@azg)3&i0Q(?&~c(tjS>d zi7`HOB6?UB!@(P}Vra+}da1fL?i{$t<|@EtcE3T#sdoFe3-|uE)!qCKcAikk3g?sJ zehA#*(8$Qh(1oY1ly_h5Cw6CF_QlOlD6VT)`c4ni_{)?>%z5>~Ue2dIZ?|}EM%tm< zd;$B;DtSTJFR0oR^s~Oewwj@z-q3_1@X9*CM3)9PpXwXNzT$3OexOxrFl!mkL!Z<3 zT+mq9ktlwR85>e27coKEAQ^4CQlKG3lb97f|8!xWO z#a7_(0@h5ZYFYN>rnQ+-#~hXoQ$Yo^{^Lv#&MDPV22PVZr)#O}w7lS4+D5=;8nb~UkwH-MwZYa#qe%>!h z=oVm{7I_p3-hvZ^eAP4~XXIw~;YiUB;VAg#PLkVWW)+za1O(qP89IJ3W>g#V?yMir zX_jpt=^ZGQU3ocK>_TR=qnPxIvC@cWiu{Yji;(u(@uOJy7rqwEZ+-bZld+{lX_{QP zVsBqexGB~Qe<#rqr_MqXev4WMh1-%NF!{8qNjB&x!&R7ib>JjvQK8cgBNeLnJ+H&j zFAop8G}0wmVS8GP6KzVDBbb9Z^|Cculf9Cwrsh`}`=0f_Z6=FHm+-VXE zl+Q{u+$b!h({G4pr!_~@+UYD1`Kg$aiSR)N{xjRrdX9(-vER%kcaQHvRyS|@X9gXh zcLHC0u7$tcp4&NHT_g@JJMynsT~u2%bw$5Z34~-`k^X)v!0HUH#N!X2aFU$}dgS z_|E$NAhH3~j8I-mqRkP$78We`0P4$8RF4>T=qx7}y~C2Kq`f4S*0cTafc8rUu^a5| zcbZ_rC#u`vRF6$m(1kcSJQm8wIi)5R6!r^(vsP>(QCo%OZM~F12;~RM#KQ8Au4}8% zj|s8ppEkot(8qWClB+TQO!@is+{UfSvOvXIy4(8q`7Xg=&#z_H1iE6kTImxIlL(jM z;W77#Z`}c2zsEq1U0?!M^9FIM;F7N#4kzJRROIh!OiPjE7pdm4qo~xkm53}+RRNCn z9=WUWK`zh~0XoIWYUo*{O2C`Cz)+Lp$i?s2uk;KPt$x_`&ItABu{XAI|9pe0moOZ@ zne*N8YH{)*VpbRL<#Zae;m0sW!j5_b$P~Mr;|Gl*9;JEq{eUFR6$?}?PZ9#8x1W6X zTI@_C4Bu^QD#VFdpYUcKlv2hAYoNR7Su%Oa*GMspv$GSy4x~cu^lJB=8)eN>hE2wV zTF3}jQ8rT!&X`t{X~uqfcXFeB7l!}-^V!Tmt-jLXIT<@8-s=w9*Lyk3^s^?)hd6qX zE@?UNRBi9sE@dj4JXlCEWm29y2xbH)qMu!>;h^$x!RyK|Nnz)UOLIi`L8y6U0%?l7 zXJW_l5^e1C-3F$hq}$-pX?FHd)fqM*NZZ{&M!bBJQC+?aLXK>9tX-Hm=$K2lDaPs_ zOh{rP{G3B3`r@!VN_CybAc%#z#Y?G3`gWW;ZOWf)p*$98K0w9ZXv8%#8ocUEufTG} zF|Dw@y>0BaqbK5puy1ioCo2*?aWSt@aJsj*H}%dcF4h`)|9ny;l?`7a*GWELl5nP5 z-R|VgyoX*BwmC0LfA9|yb208}*+aC08Q4K1;@b8D=FuzVo-^v{RFmC!W}hPX9`tg8 zNiW@Z2#ghomWM}dHSJFDsjWuW=?T7H%Nk(zYBstD3OFpEzaMjFs_dco{ZRMHh86$N zntS4!u5?S6cS2t=ZKKk@gfGG`8fObSVCopcly=8~)Bo`AqJ{|bu_j4($!qPh>anPZ zBE!Il0hu2GK`Zf}%&=)77kwziC@$c1jckjBJmJS!GW85)2nxJew39>k8xE&F-` z7sMAQh1-BJERBa?G~XV$X+~LFZ8a?m9e@3{D)ZC$d+MAQX#`mYzfvUa79pKH8a&)5 zwa$BQp2H6C`gDLaplHpRrNb zo}Y$|D0!>ivH514fw9Uxzu0x3IN$6emCc!5;aFt?!fH-`xO(>_BrL*Q|HZh!2eiPv z{-)FGAY3+uw0b?_G8=gmk_$EIB|%>bblPO|dhc@cvhQGZH@eR+B$O}hRC(cK<$BHU z+C|9s91cOynAm6qDU^&%=%?`nc5~FfPpB z{oUi!LqN6gE82fOJOuEHqQEZ+fYmAvV7kZ^y!RKB24aiZK$1XvaX1*3>`_nzRs_(1 zyb=f~0~jxf0LxK6iR@(HSHsF4WS5)(Xjd}h+G@wiw2{@`l1vG2Oz;3)xa(fLIn4a$m_Sa%P-45ScRKTp844n0s^a2>@HUr53>^+5`wZ~B$IB*kqvKaP~f&B~~En+}R zuNep*80(V-ls!-Yw>}+E<0GpCzcG9YTYHK<%|II<17H6w*$!BMQ;eRXBi;x=i5JV0 zW77*4^*@UUG5%vf2E@HNo(xxmWZ;f}$?|_m6#vuS|0lsCvN!qbY)SsncK`oQAIRt- z0ZNC+z^5ia<)}D-Hp~W2v3!IQ0CZRw3~T!bA^^T_C;-L?1RU+~B>9Z+gD)JPV3<1w z5H^AeV2_f4Ke{|ha!)JqVH5)D0xCuWz`wnL$}t(hKOPnMFa`mq_&-u_uyg3sY=?0k z@O;=GhyWORBRwT^&BI3j=edYR{@ZfzjmiAazmosC<@o137`&Lr3xh-SfA2v4nc{y+ i&wr(GO!zAW-T$vdDvIz3fBBRj-x&}XnBb(p*#7|@cE9id delta 6274 zcmZXYbyyW$+qc<6$7TZpg2HA?vq4(vl15TMLOP{EK$Gp52%@w|m!c?L z((rO~`|v&A`_3H49M^gNu359z95er{$VT*-T=a@)^r~2Nd2)3A>V&E}$|?-#AmM9W zZcVdn4iYr9JTM(@h&pwc;jg{$*wZ3XW*;Rqaa-SHCvU*n+_0-^>e=88;0>6PHle8Q zp0uVPVO4n99DI4`1%EfcLuWTlIa~kSMt%97$I*@u?1^Bq{FbtEyxe%(dxRS8L8nH_ z{vskVmfKMi_d!w?zetY>yEZk>5h)+Wh$0iqd}o4+3My0R2Z|f_J3j{QA#FJ5KC7@hzN1OSbOy0)Z z*cc*OT>GjEc;>aDLUIXV%VxCGW*K^!j$Dvz}CvSMhH@O)CFkjh_|8Mh2>pCo-M_7e%#g24^z*R5ot*rR_6Py9GCN4hrsx!tmKImSEqMhsyP+GW3B07#`>Tq+W6uzx4Ip}bX?K6PU0Qwl3Y?u z&G3L{m7QM3v`4=ic|Rxon$TI#m*>3O5XPZkL}LD2Fu@aLll3SEe(w{^-a+$8QmvYU ztCJGuiRQ+!Uy^8MOX|8!sBr!Faz1QJ>|DR3Z2oL0#JTcC6=d+!|6h3;m%*S<_g7vPneSZ?9ukBvbomINzFStIIJfD?3&v2ooQ=d{M<>{^eP~CL zy^k2el-uzNv;%cd#4jWW)(S>x_jaBxJJ6l`Z{MH#DJ{M?M0%N)d(=x&4$+>ko=89M zLq!>#_A3V4A&XppozaNBZ41(z6=`d3uAhDB7NWXtWf+z-rhc+R?z>(v+*t99GH?~c zs!5>)Ww<(1GfH+VJ^b4X$qx-)OwrUrohKJ78(%n*e)<=z?VimY8~QoSQ@ho=zS2ny z#NH_#4B3bKj`Mm}#GZUrsx=hr+d6eRz3?{pxqZ$sq0{tf99HE*CNJ%Q%QKT#Qbogx zt}$*$lv6$=ypHZE{Du+<>yyBCdt<%cS9&B6iRuuz9Tc&@vmD;+Z*6&B!LZ$slH>U6 zW4+F>RF)L4LzzB|ET{%#2~w}4#|BEVE7jtpXqb9&TKCDv7WVmwz(EtC?(2=$#9 zMoG|~rMVv|o(#RaY+^ijkV}K@VcwpsK@j(xvLGL)0H%?Mra*1ElcxV`=qvPaOlLo_)^N`CRH^Sh z*|tPrJ&P1s5t5-Y$s8Giw)S}M%rMv%U~RRs`McmPiO=TZ)6Y+x%2J-be=rHnj^l#K z&^$`2*+zZ)PJ@Z%wl5PsG*vupgi>xp(iWjF1PIruF$VOR@g#5t)uM%!WlL)Jj2wm# zF)jBJ%1L<)8J(~jnWW(&SWFA!4xgK_l+)3Bhgq2U4>!EGA~p6imyAP@t21;EY(%{0 zz?kxJ2y<*SO`ZeQHs%gAejE4mOt;cbTRUwz3eDoER#|z3)2h2ay`DH9w{NqFBRJr@Q?8Mx6mR?%%c{mk>0wQ8N?ReJAa#?1&Rwt zk0RP-J#Fl55xH*uan8=$5mw^zVhcu3V7k6Kds}6BejU647vA!x)Nq=} za4kbV>v!1e)*-8yM>LFgdA`0PWpO;k9q0Jr=MrgJSDN|uMET7o1{(80TEP-j)E&6p_6$)mv8EyTlD z)}luUN%6S0b-_+Eao5&KwQoC9_scCiy*xXG6l=9TFMgs4;qNwukP~4*1uGnKV z_;H%)K2DH?Eo3>U8NjTC&QD;_eL!p#AbEgxkZVg5U>JnV){aRc!Cmgbi69b?3eGa1 zs2rzsV!msoEwm0vy|s*D)!o+aJFS#fQ6?&Z6l6`nT4&dUyAQ;D`9p$!PPu)Dua)<0 z#cUIlIe=_(P&>GDHi;ue(O_f!L|4^&Bvj*=U4grRbDQ(m^pubMMztKgSU8M zN*eXNJR2I+xr681bFO2^HiVVCQ2s1VY@BjbYDG17mLUd0&XXZt{W2cEZ=`Vf-|=Gf+0UHnMMs;D zUVxk}bq}sVok)XG5(6)ui-Ho|%jGNddD1QiMg)>go<;n8*ys}P=i+3B6j>HIc-+r$tJc)|wdLK4dfg7Ri8Y_m0N8{NuSE&s zu&pa<4;G2%&}20Cg&x;v9RrsRK}zC6n3;#4PiQlWx`4%^Y+6<8wSBOn0tVdvoCH#f z*}6qFxV^;iZD~F_;>-6dbB^>7d*@h1*kmM?#KSPJXV7}gWP=5xiuf{V;C{LDk-Uu@ zPDm&QE5+*-i?IyMVaNJxg}E4IA6vVtiO08GXR+>nnZNXFWsOQu}v zPjFc!b{_u=h3s5rTCL$+jPMnzOF8hS=-}+93)+1aHP3Sa%md%CSJ6{-UKjcIq>u5Z zv3CT-X6d^GLgr-D+2lQNMZ9Q=fsB1Rf`U=i&ToL6)s&OPYC z9m(czK6-iAue4!{5nha+@5FGFz7noixxkyns}vZhYedJFv#<(ia;y}>v2xjtMf z+)XZja+wWRTplP6e{;uRGjaaM_I#wtbF;kZ<&YwV8YeLeeKUm*N(^#AN0ur1M&We% z3y2Z@Xx>>W8Ds*#88iM_)y1Et&5jRe=fQVoHecTA>tL3BOGKLYTXe&>j@jHfKls!y z>4j0lH&oKrl!=wW*oL_S)?NCX4fv=i2r!MHh6QcKT>><=w;#HHbVjUCJ~&+%jhMCT87C9VUt`>tPCW~J|2aZXCf*U2N}Y@pmklo?PWJS$4Q#}& z>Egr@)Uf$%A=%IH*2C}Nc!B_pnEZ^pMSGKS30$a@b&a? zCp(9g*_|kQB!vXvg>S3FAofO`gzUPBA4!zxqj1Z*?KNq&)p+6NYcw+t5Fmc~3Pot_}5h#!(LYI@B|SWXkH1apF|lK3X`}+H z$6LMz*b}@!X34T0&bD(5wi>#%ySN0SY`a+=_W0;<=Xb)DJE#}6=?az56Z*Q-CP>1L zY>kzCdD3g&-!Bb`N`GN%go#C}$EU*N9_mnBZQ~}DK0u|&R~`P=Vjw=~S$UQ@r$Oz; z^e+s2N?1$2iyvXUkWq}9_Xf*j)^CA7!r##0?lFzvq}K{3;_DYPJdN-T?ajXjLH+(p zHPc1jQli~+(>=gnW?Jv}{7|-rY{t?#h~BT7pf|Ni|{WXkrTUXvB}A zw_=k_7S^H(s!hdDoq4PhMmTLxUTJ`5R9)r2GMno56hw;VW20474ATO4wNE$~=$P97 z(4zLjoILP_d0q^4#=}={74OChmNA(crs_z#)= zWbY273wv&k*Mci~s4F0LU1eH5AyowySGP~cmL@pIp8E-`hr{_$kmP<`^~@v%Jn zm%TbLXI)PF`ma*D`C~l8fzv|9baKgyfiA6CSQ{b=ksIKK+C5m)pOtq3ANWzKaXE1B zaOL~kpPmuxN$@7Wunmpu!2Zg~7`Qu`6gDvIx@N-g%7+z!wpWdPFotPqaaa&Qp`d)34Z&ivc3)ojA-+kzygbADdrXm?!r>nJ`@X zO)5H)3MbKGQkLl}+wI6IYHgH)_SQ#_yEL{TgiC+4^7kZiKggJI#@0bfDAw?IBXH?b zW>XCEoyQ6tijPW^)-UnKodO{v4ka9?3QlKb_wHt+y#?zN^OKY$yx;@anLJUv@EdBe&N{0G(e z2CLnC2(CDu(8_MLhOC6U?0T!^Gi#E8BeND5uXpQ4#X_gEiwPxACNWaXouq%f}Y?Zx;w}+!G^W{pc>|_>&AC`Wk=F%j@Pu#8bTiwQE9*n~B zso`9oE}?9>{GC_zYp9V0)-S?jmh>tI)^Ahw%I?XmSM%zUQAfaQ)Nv)-ENhPG1N7LQ z&4X5D?D*Bk``JDTzxee8&2_%h(rWSX8GV~rE+`sany|xW>Q0Zl{~bn?%>h8Sa4h5p z4aIL2a0ODi#u=0KpF#sZEl+U8C28KBQ<6Q)5fBcKvA9=8WK$Jiz}I8YlvhWKo@ibK z{zygKGI`bvB@sqVD&6xjF$`W_S9CeGt2Onqex9@RoJXu2*MAk-NIaW;{@DqFFBv8vw`M~h<>B^MVrvGI!pU9)2$ z(h)Q?GRBBJMvvEs%nJY;yQuh(Ph~OLix7-1p zth(h{Bu{OIe#SMN5L0_fjs>ssw?8d#Hc)8V?anT4e#+u94qdqOW8rMzsryjR7A2-5 zLGi0ki4w)FGacrPjD2gz2uE2HWp)>5VUyKLNnM+Qd(v73qT zIray>@k(bJAp{yH3&8!0bR!bQmTLe(=`qYV1tW~U|?M%5~yMRFGX=ZH7qF-=+&}s4t~(7 z$sed;y=fG0<^!yFZ!lQ}3VO5=flJMI0J{e_TCPPL@PBxNrK-5#doU_62I}{40GT_u9xsm*OrVE_s2Jq0Dk_`uQuDWhZ3kYfdEipmV z3p{Y(6B5|{SFwNA2RwDI(*|csaPBh_z<73rqM(8+BWO2>1cLuTG4Qji#1#^N3`1}L zsdudkhls%wcT(_T5DP3H5(Rqy)$GHjfQkOU9d1G(bOZ^U{EO}*Hb92Kb+Y0vdp(@n zC>-(#6d#iYqdf$#&A0~%SX@N_nZL66fUnVYJM*|cKxlkjZg}B=!{g6@y#Jv5^=--% zaNvo_RR=eiIUxd^SYDT}zmkFTSF`5+iUdq;{wf7v%l>Z(1F0wZ0WGH+EOdi`tdj&_ z)g&DF<$R;vM@YbesjG3O;1GIHZORW&^STM)iNqk|^wla+H%i`<2+X-sV<9(+XyySR v6n=x5*;wG#IPUesa%SK_M&$n&QF{}St3JlW`sV{vygK<<(9m3C{-OT?q*SmI diff --git a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm index 8c778061..9f4e75ee 100644 --- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm @@ -4301,7 +4301,7 @@ tcl::namespace::eval textblock { if {[dict get $opts -frame]} { #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + set output [textblock::frame -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table [a]" [$t print]] } else { set output [$t print] } diff --git a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.6.tm b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.6.tm index dddcd0bb..7abbaeae 100644 --- a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.6.tm +++ b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.6.tm @@ -265,7 +265,7 @@ namespace eval tomlish { #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey #DDDD switch -exact -- [lindex $sub 0] { - STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - TABLE - ARRAY - ITABLE { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - TIME-TZ - TABLE - ARRAY - ITABLE { lappend values $sub lappend value_posns $posn } @@ -311,18 +311,16 @@ namespace eval tomlish { lassign [lindex $values 0] type_d1 value_d1 lassign [lindex $values 1] type_d2 value_d2 #DDDD - if {$type_d1 ne "DATE-LOCAL" || $type_d2 ni {DATETIME TIME-LOCAL}} { + if {$type_d1 ne "DATE-LOCAL" || $type_d2 ni {TIME-TZ TIME-LOCAL}} { #we reuse DATETIME tag for standalone time with tz offset (or zZ) error "tomlish KEY in 2 parts does not appear to be datetime '$keyval_element'" } if {$type_d2 eq "TIME-LOCAL"} { set type DATETIME-LOCAL - } else { - #extra check that 2nd part is actually a time - if {![tomlish::utils::is_timepart $value_d2]} { - error "tomlish KEY in 2 parts does not appear to be datetime. (part 2 not a time value) '$keyval_element'" - } + } elseif {$type_d2 eq "TIME-TZ"} { set type DATETIME + } else { + error "tomlish KEY in 2 parts does not appear to be datetime. (part 2 not a time value) '$keyval_element'" } set value "${value_d1}T${value_d2}" } @@ -332,6 +330,10 @@ namespace eval tomlish { } set sub_tablenames_info [dict create] switch -exact -- $type { + TIME-TZ { + #This is only valid in tomlish following a DATE-LOCAL + error "tomlish type TIME-TZ was not preceeded by DATE-LOCAL in keyval '$keyval_element'" + } INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL { #DDDD #simple (non-container, no-substitution) datatype @@ -383,8 +385,8 @@ namespace eval tomlish { } - proc to_dict {tomlish} { - tomlish::dict::from_tomlish $tomlish + proc to_dict {tomlish {returnextra 0}} { + tomlish::dict::from_tomlish $tomlish $returnextra } @@ -437,7 +439,8 @@ namespace eval tomlish { #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW # #TODO - set tomlpart "x=\"\"\"\\\n" + #set tomlpart "x=\"\"\"\\\n" ;#no need for continuation + set tomlpart "x=\"\"\"\n" append tomlpart [tomlish::utils::rawstring_to_MultiBstring_with_escaped_controls $val] append tomlpart "\"\"\"" set tomlish [tomlish::from_toml $tomlpart] @@ -519,6 +522,10 @@ namespace eval tomlish { lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} } else { if {$vinfo ne ""} { + if {![tomlish::utils::string_is_dict $vinfo]} { + #e.g tomlish::dict::from_tomlish was called with return_extra 1 + return -code error -errorcode {TOMLISH SYNTAX INVALIDDICT} "tomlish::_from_dictval Supplied dict is not a valid format for converting to tomlish" ;#review + } #set result [list DOTTEDKEY [list [list KEY $k]] = ] #set records [list ITABLE] @@ -645,6 +652,10 @@ namespace eval tomlish { } } else { if {$vinfo ne ""} { + if {![tomlish::utils::string_is_dict $vinfo]} { + #e.g tomlish::dict::from_tomlish was called with return_extra 1 + return -code error -errorcode {TOMLISH SYNTAX INVALIDDICT} "tomlish::_from_dictval Supplied dict is not a valid format for converting to tomlish" ;#review + } set lastidx [expr {[dict size $vinfo] -1}] set dictidx 0 set sub [list] @@ -1512,7 +1523,7 @@ namespace eval tomlish { if {[::tomlish::utils::is_int $tok]} { set tag INT } else { - if {[string is integer -strict $tok]} { + if {[::tomlish::utils::string_is_integer -strict $tok]} { #didn't qualify as a toml int - but still an int #probably means is_int is limiting size and not accepting bigints (configurable?) #or it didn't qualify due to more than 1 leading zero @@ -1522,30 +1533,28 @@ namespace eval tomlish { #DDDD if {[::tomlish::utils::is_float $tok]} { set tag FLOAT - } elseif {[::tomlish::utils::is_localtime $tok]} { + } elseif {[::tomlish::utils::is_time-local $tok]} { set tag TIME-LOCAL } elseif {[::tomlish::utils::is_timepart $tok]} { - #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a previous localdate - set tag DATETIME ;#?? review standalone time with tz - no specific tag - only allowed as followup value from DATETIME-LOCAL - } elseif {[::tomlish::utils::is_datepart $tok]} { + ###################################### + #Note we must allow lone timepart here (not just is_time-local which doesn't allow tz offsets) in case it followed a previous localdate + #set tag DATETIME ;#PLACEHOLDER tag - review standalone time with tz - no specific tag - only allowed as followup value from DATE-LOCAL + set tag TIME-TZ + #This will become a DATETIME or a DATETIME-LOCAL (or will error) + ###################################### + } elseif {[::tomlish::utils::is_date-local $tok]} { set tag DATE-LOCAL - } elseif {[::tomlish::utils::is_datetime $tok]} { + } elseif {[::tomlish::utils::is_date_or_time_or_datetime $tok]} { #not just a date or just a time #could be either local or have tz offset #DDDD JJJ set norm [string map {" " T} $tok];#prob unneeded - we won't get here if there was a space - would arrive as 2 separate tokens review. lassign [split $norm T] dp tp - if {[::tomlish::utils::is_localtime $tp]} { + if {[::tomlish::utils::is_time-local $tp]} { set tag DATETIME-LOCAL } else { set tag DATETIME } - } elseif {[::tomlish::utils::is_datetime X$tok] || [::tomlish::utils::is_timepart X$tok]} { - # obsolete - #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a previous localdate - #e.g x= 2025-01-01 02:34Z - #The dict::from_tomlish validation will catch an invalid standaline timepart, or combine with leading date if applicable. - set tag DATETIME } else { error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" } @@ -1662,6 +1671,433 @@ namespace eval tomlish { } + #return TOMLISH { value} from new and existing typeval dicts of form {type value value} but + # some such as MULTISTRING can be of form { ...} + # + #Don't validate here - validate in tomlish::dict::path::setleaf + proc _update_tomlish_typeval_convert_to_new_from_existing {new existing} { + #we deliberately don't support container types that can contain comments e.g ARRAY, ITABLE, DOTTEDKEY + #This is also not for higher level constructs such as TABLE, TABLEARRAY + if {!([tomlish::dict::is_typeval $target] && [tomlish::dict_is_typveval $source])} { + error "_update_tomlish_typeval_convert_to: target and source must be of form {type value are contained in the table + foreach tr $tablechildren { + set tr_type [lindex $tr 0] + switch -- $tr_type { + NEWLINE - WS - COMMENT { + lappend updated_tablechildren $tr + } + DOTTEDKEY { + #review + #UUU + set dktomlish [list TOMLISH $tr] + set dkdict [::tomlish::to_dict $dktomlish] + set newdktomlish [update_tomlish_from_dict $dktomlish $subd] + set newrecords [lrange $newdktomlish 1 end];#strip TOMLISH + lappend updated_tablechildren {*}$newrecords + } + default { + error "update_tomlish_from_dict: unexpected table record type $tr_type" + } + } + } + + #todo - add leaves from subd that weren't in the tablechildren list + #ordering? + + lappend output_tomlish [list {*}[lrange $tomlish_record 0 1] {*}$updated_tablechildren] + } + DOTTEDKEY { + #We don't have to check toml table rules regarding created/defined here as dict::from_tomlish has already ensured correctness + #UUU + set dkinfo [tomlish::get_dottedkey_info $tomlish_record] ;#e.g keys {j { k} l} keys_raw {j {' k'} l} + set keys [dict get $dkinfo keys] + set dk_refpath [lmap k $keys {string cat @@ $k}] + + set kvinfo [tomlish::_get_keyval_value $tomlish_record] + set existing_typeval [dict get $kvinfo result] + if {[tomlish::dict::is_typeval $existing_typeval] && [dict get $existing_typeval type] ne "ARRAY"} { + #leaf in supplied tomlish - source dict must also be leaf (invalid to rewrite a branch) + #e.g + #DOTTEDKEY {{KEY j} DOTSEP {SQKEY { k}} DOTSEP {KEY l}} = {INT 0} {WS { }} {COMMENT comment} {NEWLINE lf} + #existing_typeval: {type INT value 0} + #e.g + #DOTTEDKEY {{KEY j} DOTSEP {SQKEY { k}} DOTSEP {KEY l}} = {MULTISTRING {WS { }} {STRINGPART x} {WS { }}} {WS { }} {COMMENT comment} {NEWLINE lf} + #existing_typeval: {type MULTISTRING value { x }} + + #see if source dict has a simple typeval to set + set new_typeval [tomlish::dict::path::get $d $dk_refpath] + if {![tomlish::dict::is_typeval $new_typeval]} { + error "update_tomlish_from_dict - update dictionary has non-leaf data at path $dk_refpath - cannot set" + } + #update if type matches. Todo - flag -allowtypechange ? + set e_type [dict get $existing_typeval type] + set n_type [dict get $new_typeval type] + if {$e_type ne $n_type} { + error "update_tomlish_from_dict - cannot change type $e_type to $n_type at path $dk_refpath" + } + #-start 3 to begin search after = + set valindex [lsearch -start 3 -index 0 $tomlish_record $e_type] + if {$valindex == -1} { + error "update_tomlish_from_dict - unexpected error - failed to find $e_type in record $tomlish_record" + } + set rawval [dict get $new_typeval value] + switch -- $e_type { + MULTISTRING { + #UUU + set newval [tomlish::utils::rawstring_to_MultiBstring_with_escaped_controls $rawval] + set toml "" + append toml "x=\"\"\"" \n + append toml "$newval\"\"\"" \n + set tomlish [lrange [tomlish::from_toml $toml] 1 end] ;#remove TOMLISH keyword + #assert tomlish is a list with a single element + #e.g {DOTTEDKEY {{KEY x}} = {MULTISTRING {NEWLINE lf} {STRINGPART aaa}} {NEWLINE lf}} + set dklist [lindex $tomlish 0] + set msrecord [lindex $dklist 3] + #e.g + #MULTISTRING {NEWLINE lf} {STRINGPART aaa} + + #error "update_tomlish_from_dict MULTISTRING update unimplemented. Todo" + lset tomlish_record $valindex $msrecord + } + MULTILITERAL { + set toml "" + append toml "x='''" \n + append toml "$rawval'''" \n + set tomlish [lrange [tomlish::from_toml $toml] 1 end] ;#remove TOMLISH keyword + set dklist [lindex $tomlish 0] + set msrecord [lindex $dklist 3] + lset tomlish_record $valindex $msrecord + } + default { + switch -- $e_type { + STRING { + #review + set newval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $rawval] + } + default { + set newval $rawval + } + } + lset tomlish_record $valindex [list $e_type $newval] + } + } + + } elseif {[tomlish::dict::is_typeval $existing_typeval] && [dict get $existing_typeval type] eq "ARRAY"} { + #e.g + #DOTTEDKEY {{KEY a}} = {ARRAY {INT 1} SEP {INT 2} SEP {INT 3}} + #DOTTEDKEY {{KEY a} {WS { }}} = {WS { }} {ARRAY {INT 1} {WS { }} SEP {INT 2} {WS { }} SEP {INT 3}} {WS { }} + #existing_typeval: {type ARRAY value {{type INT value 1} {type INT value 2} {type INT value 3}}} + + #= is always at index 2 (any preceding whitespace is attached to keylist) + set valindex [lsearch -start 3 -index 0 $tomlish_record ARRAY] + if {$valindex == -1} { + error "update_tomlish_from_dict - unexpected error - failed to find ARRAY in record $tomlish_record" + } + + set existing_arraytomlish [lindex $tomlish_record $valindex] + puts "update_tomlish_from_dict: existing_arraytomlish: $existing_arraytomlish" + set subd [tomlish::dict::path::get $d $dk_refpath] + #set existing_items [tomlish::dict::from_tomlish $tomlish_record] ;#utilise fragment processing of dict::from_tomlish - to produce a LIST + #we expect the subdict structure to be something like: + # {type ARRAY value {{type INT value 1} {type INT value 2}}} + # or with untagged subdicts (ITABLE in tomlish) + # {type ARRAY value {{x {type INT value 1}} {type INT value 2}}} + + + #we can only have one ARRAY record - so we can use lset + set newsubrecord_itable [update_tomlish_from_dict [list $existing_arraytomlish] $subd] + lset tomlish_record $valindex [lindex $newsubrecord_itable 0] ;#passed in a single element tomlish list - expect only one back + + } elseif {[tomlish::dict::is_typeval_dict $existing_typeval]} { + #Not actually a {type value } structure. + #sub dict (ITABLE) + #e.g + #DOTTEDKEY {{KEY j} DOTSEP {SQKEY { k}} DOTSEP {KEY l}} = {ITABLE {DOTTEDKEY {{KEY q}} = {INT 1}}} {WS { }} {COMMENT comment} {NEWLINE lf} + #DOTTEDKEY {{KEY x} {WS { }}} = {WS { }} {ITABLE {WS { }} {DOTTEDKEY {{KEY j}} = {INT 1} {WS { }} SEP} {WS { }} {DOTTEDKEY {{KEY k} {WS { }}} = {WS { }} {INT 333}}} {WS { }} {COMMENT {test }} + #existingvaldata: {q {type INT value 1}} + set subd [tomlish::dict::path::get $d $dk_refpath] + #= is always at index 2 (any preceding whitespace is attached to keylist) + set valindex [lsearch -start 3 -index 0 $tomlish_record ITABLE] + if {$valindex == -1} { + error "update_tomlish_from_dict - unexpected error - failed to find ITABLE in record $tomlish_record" + } + #we can only have one ITABLE record - so we can use lset + + set itablerecord [lindex $tomlish_record $valindex] + puts "update_tomlish_from_dict: existing_itabletomlish: $itablerecord" + set newsubrecord_itable [update_tomlish_from_dict [list $itablerecord] $subd] + lset tomlish_record $valindex [lindex $newsubrecord_itable 0] + } else { + #unreachable? - dict::from_tomlish didn't object. + error "update_tomlish_from_dict: Unexpected data in DOTTEDKEY record: $existing_typeval" + } + lappend output_tomlish $tomlish_record + } + ARRAY { + #UUU + #fragment recursion + puts "update_tomlish_from_dict: process ARRAY fragment" + puts "tomlish:\n$tomlish" + puts "updatedict:\n$d" + set source_d_elements [tomlish::dict::path::get $d {[]}] + + set updated_arraychildren [list] + set arrayrecord $tomlish_record + set arraychildren [lrange $arrayrecord 1 end] ;#includes WS, SEP, NEWLINE, COMMENT + set arridx 0 + set childidx 0 + foreach arrchild $arraychildren { + set arrchild_type [lindex $arrchild 0] + switch -- $arrchild_type { + SEP { + #we don't check for proper SEP interspersal here, presuming well-formed tomlish - review + lappend updated_arraychildren $arrchild + } + NEWLINE - WS - COMMENT { + lappend updated_arraychildren $arrchild + } + default { + #updatables + #review - type changes from existing value?? + set sourcedata [lindex $source_d_elements $arridx] + switch -- $arrchild_type { + STRING - LITERAL - FLOAT - INT - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL { + #basic types - no recursion needed + #REVIEW - change of type? flag to allow/disallow? + if {![tomlish::dict::is_typeval $sourcedata]} { + error "update_tomlish_from_dict - update dictionary has non-leaf data at path \[$arridx\] - cannot set" + } + set newval [dict get $sourcedata value] + set newtype [dict get $sourcedata type] + if {$newtype eq "STRING"} { + set newval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $newval] + } + lappend updated_arraychildren [list $newtype $newval] + } + MULTISTRING { + #no need to recurse + puts stderr "multistring within array update - unimplemented" + } + MULTILITERAL { + #no need to recurse + puts stderr "multiliteral within array update - unimplemented" + } + ITABLE - ARRAY { + #recurse + puts stderr "update $tomlish_type within array" + set nextd [tomlish::dict::path::get $d $arridx] + set subrecord_tomlish [list $arrchild] + set newsubrecord_tomlish [update_tomlish_from_dict $subrecord_tomlish $nextd] + lappend updated_arraychildren {*}$newsubrecord_tomlish + } + default { + error "update_tomlish_from_dict: unexpected array child record type $arrchild_type" + } + } + incr arridx ;#only increment array index for updatables + } + } + } + + lappend output_tomlish [list ARRAY {*}$updated_arraychildren] + } + ITABLE { + #fragment recursion target + #ITABLE {DOTTEDKEY {{KEY j}} = {INT 1}} + #ITABLE {WS { }} {DOTTEDKEY {{KEY j}} = {INT 1} {WS { }} SEP} {WS { }} {DOTTEDKEY {{KEY k} {WS { }}} = {WS { }} {INT 333}} + #ITABLE {NEWLINE lf} {DOTTEDKEY {{KEY j} {WS { }}} = {WS { }} {INT 1} SEP} {WS { }} {COMMENT test} {NEWLINE lf} {WS { }} {DOTTEDKEY {{KEY k}} = {WS { }} {INT 2} {NEWLINE lf}} + puts "update_tomlish_from_dict: process ITABLE fragment" + puts "tomlish:\n$tomlish" + puts "updatedict:\n$d" + set updated_itablechildren [list] + set itablechildren [lrange $tomlish_record 1 end] ;#includes WS, NEWLINE, COMMENT (possibly SEP - though it may be attached to DOTTEDKEY record REVIEW) + #we only expect DOTTEDKEY records for data items within ITABLE + foreach itablechild $tomlish_record { + set itablechild_type [lindex $itablechild 0] + switch -- $itablechild_type { + SEP { + #REVIEW + #we don't necessarily expect a SEP *directly* within ITABLE records as currently when they're created by tomlish::from_toml + #it attaches them (along with intervening WS, COMMENTs) to each DOTTEDKEY record + #This feels somewhat misaligned with ARRAY - where we have no choice but to have SEP, and COMMENTs independent of the array elements. + #Attaching COMMENTs, SEP to the previous DOTTEDKEY has some merit - but perhaps consistency with ARRAY would be preferable. + #This may change - but in any case it should probably be valid/handled gracefully either way. + lappend updated_itablechildren $itablechild + } + COMMENT - WS - NEWLINE { + lappend updated_itablechildren $itablechild + } + DOTTEDKEY { + puts stderr "update dottedkey in itable: tomlish:[list $itablechild] d:$d" + set updatedtomlish [update_tomlish_from_dict [list $itablechild] $d] + set newrecord [lindex $updatedtomlish 0] + lappend updated_itablechildren $newrecord + } + } + } + + lappend output_tomlish [list ITABLE {*}$updated_itablechildren] + } + default { + error "update_tomlish_from_dict: Unexpected toplevel type $tomlish_type record: $tomlish_record" + } + } + } + return $output_tomlish + } + #*** !doctools #[list_end] [comment {--- end definitions namespace tomlish ---}] @@ -1713,7 +2149,7 @@ namespace eval tomlish::build { } proc DATETIME {str} { - if {[::tomlish::utils::is_datetime $str]} { + if {[::tomlish::utils::is_date_or_time_or_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]" @@ -2027,6 +2463,127 @@ namespace eval tomlish::utils { #[para] #[list_begin definitions] + #------------------------------------------------------------------------------ + # Tcl 8.6 support + #------------------------------------------------------------------------------ + if {[catch {tcl::string::is dict {}}]} { + proc string_is_dict {str} { + #we don't support -strict or -failindex for this fallback + expr {[::tcl::string::is list $str] && ([llength $str] % 2 == 0)} + } + } else { + proc string_is_dict {str} { + #we don't support -strict or -failindex for this fallback even though underlying supports it + ::tcl::string::is dict $str + } + } + if {![string is integer [expr {2**32}]]} { + proc string_is_integer {args} { + ::tcl::string::is entier {*}$args + } + } else { + proc string_is_integer {args} { + ::tcl::string::is integer {*}$args + } + } + #------------------------------------------------------------------------------ + + #subset of jq syntax for get/set operations on dicts + # no filters or multiple targets + # meant for 'leaf' queries + proc jq_to_path {jq} { + set jq [string trim $jq] ;#don't tokenize any leading/trailing whitespace + set path [list] + set in_arr 0 + set in_dq 0 + set tok "" + set bsl 0 + foreach c [split $jq ""] { + if {$c eq "\\"} { + if {$bsl} { + set bsl 0 + set c "\\" + } else { + set bsl 1 + continue + } + } else { + if {$bsl} { + set c "\\$c" + set bsl 0 + } + } + if {$in_arr} { + switch -- $c { + {]} { + set in_arr 0 + lappend path $tok + set tok "" + } + default { + append tok $c + } + } + } elseif {$in_dq} { + if {$c eq "\""} { + set in_dq 0 + #append tok "\"" + lappend path $tok + set tok "" + } else { + append tok $c + } + } else { + switch -- $c { + . { + if {$tok ne ""} { + lappend path $tok + } + set tok "@@" + } + {[} { + if {$tok ne ""} { + lappend path $tok + } + set in_arr 1 + set tok "" + } + {"} { + if {$tok eq "@@"} { + #set tok "@@\"" + set in_dq 1 + } else { + append tok "\"" + } + } + default { + append tok $c + } + } + } + } + if {$tok ne ""} { + lappend path $tok + } + return $path + } + proc path_to_jq {path} { + set jq "" + foreach p $path { + if {[string match @@* $p]} { + set key [string range $p 2 end] + if {![tomlish::utils::is_barekey $key]} { + set key [subst -nocommands -novariables $key] + set key "\"[tomlish::utils::rawstring_to_Bstring_with_escaped_controls $key]\"" + } + append jq ".$key" + } else { + append jq {[} $p {]} + } + } + return $jq + } + #basic generic quote matching for single and double quotes @@ -2225,16 +2782,78 @@ namespace eval tomlish::utils { return [string map $map $str] } - proc rawstring_is_valid_tomlstring {str} { - #controls are allowed in this direction dict -> toml (they get quoted) + #anything is valid in this direction ?? review + #proc rawstring_is_valid_tomlstring {str} { + # #controls are allowed in this direction dict -> toml (they get quoted) + + # #check any existing escapes are valid + # if {[catch { + # unescape_string $str + # } errM]} { + # return 0 + # } + # return 1 + #} + + + #REVIEW - easier way to validate? regex? + #This is not used for the parsing of toml to tomlish, + # but can be used to validate for updating via dict e.g when setting with tomlish::dict::path::setleaf + proc inner_MultiBstring_is_valid_toml {str} { + set without_literal_backslashes [string map [list "\\\\" ""] $str] + #replace only escaped dquotes - use a placeholder - we don't want unescaped runs of dquotes merging. + set without_escaped_dquotes [string map [list "\\\"" ""] $without_literal_backslashes] + + if {[string first "\"\"\"" $without_escaped_dquotes] != -1} { + return 0 + } + #assert - all remaining backslashes are escapes - #check any existing escapes are valid + #strip remaining dquotes + set dquoteless [string map [list "\"" ""] $without_escaped_dquotes] + #puts stderr "dquoteless: $dquoteless" + + #check any remaining escapes are valid if {[catch { - unescape_string $str + #don't use the returned value - just check it + unescape_string $without_literal_backslashes } errM]} { return 0 } - return 1 + + + variable Bstring_control_map + #remove backslash from control map - we are happy with the remaining escapes (varying length) + set testmap [dict remove $Bstring_control_map "\\" \r \n] + set testval [string map $testmap $dquoteless] + #if they differ - there were raw controls + return [expr {$testval eq $dquoteless}] + } + proc inner_Bstring_is_valid_toml {str} { + set without_literal_backslashes [string map [list "\\\\" ""] $str] + #replace only escaped dquotes - use a placeholder - we don't want unescaped runs of dquotes merging. + set without_escaped_dquotes [string map [list "\\\"" ""] $without_literal_backslashes] + + #plain Bstring can't have unescaped dquotes at tall + if {[string first "\"" $without_escaped_dquotes] != -1} { + return 0 + } + #assert - all remaining backslashes are escapes + + #check any remaining escapes are valid + if {[catch { + #don't use the returned value - just check it + unescape_string $without_literal_backslashes + } errM]} { + return 0 + } + + variable Bstring_control_map + #remove backslash from control map - we are happy with the remaining escapes (varying length) + set testmap [dict remove $Bstring_control_map "\\"] + set testval [string map $testmap $without_escaped_dquotes] + #if they differ - there were raw controls + return [expr {$testval eq $without_escaped_dquotes}] } proc rawstring_is_valid_literal {str} { @@ -2695,7 +3314,7 @@ namespace eval tomlish::utils { set numeric_value [tcl::string::map {_ ""} $str] ;#allow some earlier tcl versions which don't support underscores #use Tcl's integer check to ensure we don't let things like 3e4 through - which is a float (would need to be 0x3e4 for hex) - if {![tcl::string::is integer -strict $numeric_value]} { + if {![::tomlish::utils::string_is_integer -strict $numeric_value]} { return 0 } @@ -2795,7 +3414,7 @@ namespace eval tomlish::utils { set dposn [string first . $str] if {$dposn > -1 } { set d3 [string range $str $dposn-1 $dposn+1] - if {![string is integer -strict [string index $d3 0]] || ![string is integer -strict [string index $d3 2]]} { + if {![::tomlish::utils::string_is_integer -strict [string index $d3 0]] || ![::tomlish::utils::string_is_integer -strict [string index $d3 2]]} { return 0 } } @@ -2826,48 +3445,9 @@ namespace eval tomlish::utils { } } - proc is_datepart {str} { - set matches [regexp -all {[0-9\-]} $str] - if {[tcl::string::length $str] != $matches} { - return 0 - } - #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) - if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { - return 0 - } - if {$m > 12 || $m == 0} { - return 0 - } - switch -- [expr {$m}] { - 1 - 3 - 5 - 7 - 8 - 10 - 12 { - if {$d > 31 || $d == 0} { - return 0 - } - } - 2 { - if {$d > 29 || $d == 0} { - return 0 - } - if {$d == 29} { - #leapyear check - if {[catch {clock scan $str -format %Y-%m-%d} errM]} { - return 0 - } - } - } - 4 - 6 - 9 - 11 { - if {$d > 30 || $d == 0} { - return 0 - } - } - } - return 1 - } - proc is_localdate {str} { - is_datepart $str - } #allow only hh:mm:ss or hh:mm (no subseconds) + #return 2 when missing seconds proc _is_hms_or_hm_time {val} { set numchars [tcl::string::length $val] if {[regexp -all {[0-9:]} $val] != $numchars} { @@ -2884,6 +3464,7 @@ namespace eval tomlish::utils { if {$hr > 23 || $min > 59} { return 0 } + return 2 ;#missing seconds indicator (can still be used as boolean for true in tcl if we don't care whether hh::mm::ss or hh:mm } elseif {[llength $hms_cparts] == 3} { lassign $hms_cparts hr min sec if {[string length $hr] != 2 || [string length $min] != 2 || [string length $sec] !=2} { @@ -2893,10 +3474,10 @@ namespace eval tomlish::utils { if {$hr > 23 || $min > 59 || $sec > 60} { return 0 } + return 1 } else { return 0 } - return 1 } proc is_timepart {str} { #validate the part after the T (or space) @@ -2922,6 +3503,11 @@ namespace eval tomlish::utils { } if {[llength $dotparts] == 2} { lassign $dotparts hms tail + if {[_is_hms_or_hm_time $hms] == 2} { + #If we have a dot - assume hh::mm::ss required + #toml spec is unclear on this but hh:mm. doesn't seem sensible - REVIEW + return 0 + } #validate tail - which might have +- offset if {[string index $tail end] ni {z Z}} { #from hh:mm:??. @@ -2930,14 +3516,21 @@ namespace eval tomlish::utils { if {![string is digit -strict $fraction]} { return 0 } - if {![_is_hms_or_hm_time $offset]} { + if {[_is_hms_or_hm_time $offset] != 2} { + #RFC3339 indicates offset can be specified as hh:mm or Z - not hh:mm:ss + return 0 + } + } else { + #tail has no +/-, only valid if fraction digits + #toml-test invalid/datetime/second-trailing-dot + if {![string is digit -strict $tail]} { return 0 } } } else { set tail [string range $tail 0 end-1] #expect tail nnnn (from hh:mm::ss.nnnnZ) - #had a dot and a zZ - no other offset valid (?) + #had a dot and a zZ if {![string is digit -strict $tail]} { return 0 } @@ -2946,8 +3539,10 @@ namespace eval tomlish::utils { } else { #no dot (fraction of second) if {[regexp {(.*)[+-](.*)} $str _match hms offset]} { - #validate offset - if {![_is_hms_or_hm_time $offset]} { + #validate offset + #offset of +Z or -Z not valid + if {[_is_hms_or_hm_time $offset] != 2} { + #offset is not of required form hh:mm return 0 } } else { @@ -2970,7 +3565,45 @@ namespace eval tomlish::utils { return 0 } } - proc is_localtime {str} { + + proc is_date-local {str} { + set matches [regexp -all {[0-9\-]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) + if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { + return 0 + } + if {$m > 12 || $m == 0} { + return 0 + } + switch -- [expr {$m}] { + 1 - 3 - 5 - 7 - 8 - 10 - 12 { + if {$d > 31 || $d == 0} { + return 0 + } + } + 2 { + if {$d > 29 || $d == 0} { + return 0 + } + if {$d == 29} { + #leapyear check + if {[catch {clock scan $str -format %Y-%m-%d} errM]} { + return 0 + } + } + } + 4 - 6 - 9 - 11 { + if {$d > 30 || $d == 0} { + return 0 + } + } + } + return 1 + } + proc is_time-local {str} { #time of day without any relation to a specific day or any offset or timezone set numchars [tcl::string::length $str] if {[regexp -all {[0-9\.:]} $str] == $numchars} { @@ -2999,9 +3632,26 @@ namespace eval tomlish::utils { return 0 } } - - #review + proc is_datetime-local {str} { + set norm [string map {" " T} $str] + lassign [split $norm T] dp tp + if {$dp eq "" || $tp eq ""} {return 0} + if {![is_date-local $dp]} {return 0} + if {![is_timepart $tp]} {return 0} + if {![is_time-local $tp]} {return 0} + return 1 + } proc is_datetime {str} { + set norm [string map {" " T} $str] + lassign [split $norm T] dp tp + if {$dp eq "" || $tp eq ""} {return 0} + if {![is_date-local $dp]} {return 0} + if {![is_timepart $tp]} {return 0} + if {[is_time-local $tp]} {return 0} + return 1 + } + #review + proc is_date_or_time_or_datetime {str} { #Essentially RFC3339 formatted date-time - but: #1) allowing seconds to be omitted (:00 assumed) #2) T may be replaced with a single space character TODO - parser support for space in datetime! @@ -3049,7 +3699,7 @@ namespace eval tomlish::utils { if {[string first T $str] > -1} { lassign [split $str T] datepart timepart - if {![is_datepart $datepart]} { + if {![is_date-local $datepart]} { return 0 } if {![is_timepart $timepart]} { @@ -3059,7 +3709,7 @@ namespace eval tomlish::utils { #either a datepart or a localtime #spec: "If you include only the time portion of an RFC 3339 formatted date-time, it will represent that time of day # without any relation to a specific day or any offset or timezone." - if {!([is_datepart $str] || [is_localtime $str])} { + if {!([is_date-local $str] || [is_time-local $str])} { return 0 } } @@ -6005,7 +6655,7 @@ namespace eval tomlish::huddle { set h [huddle::json::json2huddle parse $json] } proc from_dict {d} { - + error "tomlish::huddle::from_dict unimplemented" } #raw - strings must already be processed into values suitable for json e.g surrogate pair escaping @@ -6213,7 +6863,7 @@ namespace eval tomlish::typedhuddle { } float { set dtype FLOAT - if {[string is integer -strict $hval]} { + if {[::tomlish::utils::string_is_integer -strict $hval]} { #json FLOAT specified as integer - must have dot for toml set hval [expr {double($hval)}] } @@ -6589,7 +7239,7 @@ namespace eval tomlish::dict { #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 {[string is dict $d] && [dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} + expr {[::tomlish::utils::string_is_dict $d] && [dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} } #simple types only - not containers? @@ -6601,8 +7251,40 @@ namespace eval tomlish::dict { set testtype integer set dval [expr {$dval}] ;#convert e.g 0xDEADBEEF to 3735928559 } - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - FLOAT - BOOL { - #DDDD + FLOAT - BOOL { + set testtype [string tolower $dtype] + } + DATE-LOCAL { + set testtype date-local + } + TIME-LOCAL { + if {[tomlish::utils::_is_hms_or_hm_time $dval] == 2} { + #add seconds for sending to json + set dval "${dval}:00" + } + set testtype time-local + } + DATETIME - DATETIME-LOCAL { + #we expect it to be basically well formed here - this is not validation - just adding possible missing seconds + if {![regexp {([tT\ ])} $dval _ dsep]} { + return -code error -errorcode {TOJSON SYNTAX INVALIDDATE} "Unable to process $dtype '$dval' - missing RFC3339 separator space or T" + } + lassign [split $dval $dsep] dp tail + + #toml allows HH:MM without seconds - but we need to add seconds 00 when passing to external systems + if {![tomlish::utils::is_time-local $tail]} { + #there is some offset component. We aren't checking its syntax here (presumed done when dict building) + regexp {([\+\-zZ])} $tail _ tsep ;#keep tsep for rebuilding + lassign [split $tail $tsep] tp offset ;#offset may be empty if z or Z + } else { + set tp $tail + set tsep "" + set offset "" + } + if {[tomlish::utils::_is_hms_or_hm_time $tp] == 2} { + #need to add seconds + set dval "${dp}${dsep}${tp}:00${tsep}${offset}" + } set testtype [string tolower $dtype] } STRING - MULTISTRING { @@ -6620,10 +7302,6 @@ namespace eval tomlish::dict { #} set dval [tomlish::utils::rawstring_to_jsonstring $dval] } - MULTILITERAL { - #todo - escape newlines for json? - set testtype string - } default { error "convert_typeval_to_tomltest unhandled type $dtype" } @@ -6634,7 +7312,7 @@ namespace eval tomlish::dict { # Check that each leaf is a typeval or typeval dict #importantly: must accept empty dict leaves e.g {x {}} proc is_typeval_dict {d {checkarrays 0}} { - if {![string is dict $d]} { + if {![::tomlish::utils::string_is_dict $d]} { return 0 } dict for {k v} $d { @@ -6858,7 +7536,7 @@ namespace eval tomlish::dict { lappend dottedtables_defined $dottedsuper_refpath #ensure empty tables are still represented in the datastructure - tomlish::dict::path::set_endpoint datastructure $dottedsuper_refpath {} ;#set to empty subdict + tomlish::dict::path::setleaf datastructure $dottedsuper_refpath {} 0;#set to empty subdict } else { #added for fixed assumption set ttype [dict get $tablenames_info $dottedsuper_refpath ttype] @@ -6911,7 +7589,7 @@ namespace eval tomlish::dict { #'create' the table dict set tablenames_info $dottedkey_refpath ttype dottedkey_table #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list - tomlish::dict::path::set_endpoint datastructure $dottedkey_refpath {} + tomlish::dict::path::setleaf datastructure $dottedkey_refpath {} 0 lappend dottedtables_defined $dottedkey_refpath # @@ -6970,7 +7648,7 @@ namespace eval tomlish::dict { #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_typeval can distinguish tomlish::log::debug "_process_tomlish_dottedkey>>> context:$context_refpath dottedkey $dottedkeyname kv: $keyval_dict" - tomlish::dict::path::set_endpoint datastructure $fullkey_refpath $keyval_dict + tomlish::dict::path::setleaf datastructure $fullkey_refpath $keyval_dict 0 #remove ? #if {![tomlish::dict::is_typeval $keyval_dict]} { @@ -6991,8 +7669,17 @@ namespace eval tomlish::dict { #} return [dict create dottedtables_defined $dottedtables_defined] } + + #tomlish::dict::from_tomlish is a *basic* programmatic datastructure for accessing the data. # produce a dictionary of keys and values from a tomlish tagged list. + # ---------------------------------------------------------------- + # NOTE: + # can instead produce a list if passed an ARRAY at toplevel + # can produce a single value if passed a MULTISTRING or MULTILIST at toplevel + # These are fragments of tomlish used in recursive calls. + # Such fragments don't represent valid tomlish that can be converted to a toml doc. + # ---------------------------------------------------------------- # dict::from_tomlish is primarily for read access to 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. @@ -7012,7 +7699,7 @@ namespace eval tomlish::dict { # versus #[Data] #temps = [{cpu = 79.5, case = 72.0}] - proc from_tomlish {tomlish} { + proc from_tomlish {tomlish {returnextra 0}} { package require dictn #keep track of which tablenames have already been directly defined, @@ -7075,13 +7762,17 @@ namespace eval tomlish::dict { #value is a dict with keys: ttype, tdefined } + if {![string is list $tomlish]} { + error "tomlish::dict::from_tomlish Supplied value for tomlish does not appear to be a tomlish list. Use tomlish::from_toml to get a tomlish list from toml." + } + log::info "---> dict::from_tomlish processing '$tomlish'<<<" set items $tomlish foreach lst $items { if {[lindex $lst 0] ni $::tomlish::tags} { - error "supplied list 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" + error "tomlish::dict::from_tomlish supplied list 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" } } @@ -7097,12 +7788,13 @@ namespace eval tomlish::dict { #puts "...> item:'$item' tag:'$tag'" switch -exact -- $tag { KEY - DQKEY - SQKEY - INT - FLOAT - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - STRING - LITERAL { - #why would we get individual key item as opposed to DOTTEDKEY? + #we don't require invalid tomlish fragments with these keys in our direct recursion + #(we do support ARRAY, MULTISTING, and MULTILITERAL tomlish fragments below) error "tomlish::dict::from_tomlish error: invalid tag: $tag. At the toplevel, from_tomlish can only process WS NEWLINE COMMENT and compound elements DOTTEDKEY TABLE TABLEARRAY ITABLE MULTILITERAL MULTISTRING" } DOTTEDKEY { - #toplevel dotted key - set dkinfo [_process_tomlish_dottedkey $item] + #toplevel dotted key empty context_refpath + set dkinfo [_process_tomlish_dottedkey $item {}] lappend dottedtables_defined {*}[dict get $dkinfo dottedtables_defined] #at any level - we don't expect any more DOTTEDKEY records in a tomlish structure after TABLE or TABLEARRAY are encountered #as those records should encapsulate their own dottedkeys @@ -7197,7 +7889,7 @@ namespace eval tomlish::dict { dict set tablenames_info $tablearray_refpath ttype header_tablearray #dict set datastructure {*}$norm_segments [list type ARRAY value {}] #create array along with empty array-item at position zero - tomlish::dict::path::set_endpoint datastructure $tablearray_refpath [list type ARRAY value {{}}] + tomlish::dict::path::setleaf datastructure $tablearray_refpath [list type ARRAY value {{}}] 0 set arrayitem_refpath [list {*}$tablearray_refpath 0] #set ARRAY_ELEMENTS [list] } else { @@ -7351,7 +8043,7 @@ namespace eval tomlish::dict { dict set tablenames_info $refpath ttype unknown_header #ensure empty tables are still represented in the datastructure #dict set datastructure {*}$supertable [list] - tomlish::dict::path::set_endpoint datastructure $refpath {} + tomlish::dict::path::setleaf datastructure $refpath {} 0 } else { #supertable has already been created - and may be defined - but even if defined we can add subtables unless it is of type itable if {[dict get $tablenames_info $refpath ttype] eq "header_tablearray"} { @@ -7396,7 +8088,7 @@ namespace eval tomlish::dict { #We are 'defining' this table's keys and values here (even if empty) #dict set datastructure {*}$norm_segments [list] ;#ensure table still represented in datastructure even if we add no keyvals here - tomlish::dict::path::set_endpoint datastructure $table_refpath {} ;#ensure table still represented in datastructure even if we add no keyvals here + tomlish::dict::path::setleaf datastructure $table_refpath {} 0;#ensure table still represented in datastructure even if we add no keyvals here } else { if {[dict get $tablenames_info $table_refpath ttype] eq "header_tablearray"} { #e.g tomltest invalid/table/duplicate-table-array2 @@ -7468,6 +8160,7 @@ namespace eval tomlish::dict { } } ARRAY { + #invalid at toplevel of a 'complete' tomlish structure - but we support it here for recursive fragment processing #arrays in toml are allowed to contain mixtures of types set datastructure [list] log::debug "--> processing array: $item" @@ -7516,6 +8209,8 @@ namespace eval tomlish::dict { } } MULTILITERAL { + #Not for toplevel of complete tomlish - (recursive fragment processing) + #triple squoted string #first newline stripped only if it is the very first element #(ie *immediately* following the opening delims) @@ -7559,6 +8254,7 @@ namespace eval tomlish::dict { set datastructure $stringvalue } MULTISTRING { + #Not for toplevel of complete tomlish - (recursive fragment processing) #triple dquoted string log::debug "---> tomlish::dict::from_tomlish processing multistring: $item" set stringvalue "" @@ -7672,82 +8368,394 @@ namespace eval tomlish::dict { } } } - return $datastructure + if {!$returnextra} { + return $datastructure + } else { + return [dict create datastructure $datastructure tablenames_info $tablenames_info] + } } } +namespace eval tomlish::path { + namespace export {[a-z]*}; # Convention: export all lowercase + + set test_tomlish [tomlish::from_toml { } #comment {z=1} {x.y=2 #xy2} {[[shop.product]] #product1} {x=[ #array1} {11 #val1} {, 12 #val2} {]} {[unrelated.' etc ']} {a.b={c=666}} {a.x={}} {[[shop.product]]} {x="test"} {[shop]} {name="myshop"}] + + proc get {tomlish {path {}}} { + if {$path eq ""} { + return $tomlish + } + if {[string index $path 0] in [list . "\["]} { + set path [tomlish::utils::jq_to_path $path] + } + + #at the cost of some performance, sanity check that the tomlish is valid + if {[catch {tomlish::to_dict $tomlish} d]} { + error "tomlish::path::get error supplied tomlish is malformed\nerrmsg: $d" + } + #since we have the dict - test the path is valid + if {![tomlish::dict::path::exists $d $path]} { + error "tomlish::path::get - path \"$path\" not found in tomlish $tomlish" + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + set tomlish [lrange $tomlish 1 end] + } + ::set pathsofar [list] + ::set tomlitems [list] ;#reducing set. 2 element list {keypath itemlist} + foreach record $tomlish { + lappend tomlitems [list {} [list $record]] ;#root records + } + + ::set dictsubpath [list] ;#reset at every index encounter? + foreach p $path { + ::lappend pathsofar $p + set sublist [list] + if {[string range $p 0 1] eq "@@"} { + set realsearchkey [string range $p 2 end] + lappend dictsubpath $realsearchkey + foreach path_items $tomlitems { + lassign $path_items subpath tlist + lappend subpath $realsearchkey + foreach item $tlist { + set tp [lindex $item 0] + switch -- $tp { + WS - NEWLINE - COMMENT { + } + DOTTEDKEY { + #can occur at toplevel (before others) or within other elements + set keyinfo [tomlish::get_dottedkey_info $item] + set keys_raw [dict get $keyinfo keys_raw] + puts stderr "subpath:$subpath -->DOTTEDKEY keys_raw: $keys_raw" + #may not be enough keys_raw for subpath - but there could be further ITABLES to continue the dict further + set prefixparts [lrange $keys_raw 0 [llength $subpath]-1] + set is_kmatch 1 ;#default assumption only + foreach dsub $subpath kpart $prefixparts { + if {$dsub ne $kpart} { + set is_kmatch 0 + } + } + if {$is_kmatch} { + if {[llength $keys_raw] == [llength $subpath]} { + set subpath [list] + #e.g {DOTTEDKEY {{KEY xxx}} = {WS { }} {STRING blah}} + lappend sublist [list $subpath [lrange $item 3 end]] + } else { + lappend sublist [list $subpath [list $item]] + } + } + } + ITABLE { + #subelement only + set itablechildren [lrange $item 1 end] + puts stderr "subpath:$subpath -->ITABLE records: $itablechildren" + set nextpath [lmap v $subpath {string cat @@ $v}] + set results [tomlish::path::get $itablechildren $nextpath] + set subpath [list] + puts "--> lappending [list $subpath $results]" + lappend sublist [list $subpath $results] + } + TABLEARRAY { + #toplevel only + set fulltablename [lindex $item 1] + set normalise 1 + set tparts [tomlish::toml::tablename_split $fulltablename $normalise] + if {[llength $tparts] < [llength $subpath]} {continue} ;#not enough parts to satisfy current subpath query + set prefixparts [lrange $tparts 0 [llength $subpath]-1] + set is_tmatch 1 ;#default assumption only + foreach dsub $subpath tpart $prefixparts { + if {$dsub ne $tpart} { + set is_tmatch 0 + } + } + #TODO reference arrays + if {$is_tmatch} { + if {[llength $tparts] == [llength $subpath]} { + set subpath [list] + lappend sublist [list $subpath [lrange $item 2 end]] + } else { + #TODO + set subpath 0 + lappend sublist [list $subpath [list $item]] ;#add entire TABLE line + } + } + } + TABLE { + #toplevel only + set fulltablename [lindex $item 1] + set normalise 1 + set tparts [tomlish::toml::tablename_split $fulltablename $normalise] + if {[llength $tparts] < [llength $subpath]} {continue} ;#not enough parts to satisfy current subpath query + set prefixparts [lrange $tparts 0 [llength $subpath]-1] + set is_tmatch 1 ;#default assumption only + foreach dsub $subpath tpart $prefixparts { + if {$dsub ne $tpart} { + set is_tmatch 0 + } + } + if {$is_tmatch} { + if {[llength $tparts] == [llength $subpath]} { + set subpath [list] + lappend sublist [list $subpath [lrange $item 2 end]] + } else { + #leave subpath + lappend sublist [list $subpath [list $item]] ;#add entire TABLE line + } + } + } + ARRAY { + #subelement only + } + + } + } + } + } else { + #index + #will never occur at toplevel (dict::path::exists already ruled it out) + foreach path_items $toml_items { + lassign $path_items subpath $tlist + set tp [lindex $tlist 0] + switch -- $tp { + ARRAY { + } + } + } + } + #temp + puts stdout "pathsofar: $pathsofar" + puts stdout [punk::lib::showdict -roottype list $sublist] + set tomlitems $sublist + } + + #REVIEW + if {[llength $tomlitems] == 1} { + return [lindex $tomlitems 0 1] + } + set result [list] + foreach i $tomlitems { + lappend result [lindex $i 1] + } + return $result + #return [lindex $tomlitems 1] + } + +} namespace eval tomlish::dict::path { - #access tomlish dict structure + + #access tomlish dict structure namespace export {[a-z]*}; # Convention: export all lowercase - #access with path such as: @@k @@k 0 @@k end where dict keys marked with @@ and plain values are list indices into in {type ARRAY value } - #leaf elements returned as structured {type value } + #access with path such as: @@k @@k 0 @@k end where dict keys marked with @@ and plain values are list indices into in {type ARRAY value } + #leaf elements returned as structured {type value } proc get {dictval {path {}}} { if {$path eq ""} { return $dictval } + if {[string index $path 0] in [list . "\["]} { + set path [tomlish::utils::jq_to_path $path] + } + ::set data $dictval ::set pathsofar [list] + ::set i 0 foreach p $path { ::lappend pathsofar $p if {[string range $p 0 1] eq "@@"} { + #dict key ::set data [dict get $data [string range $p 2 end]] } else { - if {![tomlish::dict::is_typeval $data]} { - error "tomlish::dict::path::get error bad path $path. Attempt to access table as array at subpath $pathsofar." - } - if {[dict get $data type] ne "ARRAY"} { - error "tomlish::dict::get error bad path $path. Subpath $pathsofar is not an array." + #ARRAY or raw list index + if {[llength $pathsofar] > 1 && [string trim [lindex $pathsofar $i-1]] eq ""} { + #previous path was query for entire list - result is a raw list, not a dict + if {[string trim $p] eq ""} { + #review - multiple {[]} in a row in the path is pretty suspicious - raise error + error "tomlish::dict::path::get error - multiple empty indices in a row not supported" + } + ::set data [lindex $data $p] + } else { + if {![tomlish::dict::is_typeval $data]} { + error "tomlish::dict::path::get error bad path $path. Attempt to access table or other value as array at subpath $pathsofar." + } + if {[dict get $data type] ne "ARRAY"} { + error "tomlish::dict::get error bad path $path. Subpath $pathsofar is not an array." + } + ::set arrdata [dict get $data value] + #when $p is empty string (or whitespace) - lindex returns entire list (or empty list) + # - this corresponds to jq: {[]} or path {""} + ::set data [lindex $arrdata $p] } - ::set arrdata [dict get $data value] - ::set data [lindex $arrdata $p] } + incr i } return $data } + proc exists {dictval path} { + #completely empty path considered to exist - review + if {[string index $path 0] in [list . {[}]} { + set path [tomlish::utils::jq_to_path $path] + } ::set data $dictval ::set pathsofar [list] ::set exists 1 + ::set i 0 foreach p $path { ::lappend pathsofar $p if {[string range $p 0 1] eq "@@"} { + #dict key ::set k [string range $p 2 end] if {![dict exists $data $k]} { return 0 } ::set data [dict get $data $k] } else { - if {![tomlish::dict::is_typeval $data]} { - return 0 + #ARRAY or raw list index + if {[llength $pathsofar] > 1 && [string trim [lindex $pathsofar $i-1]] eq ""} { + #previous path was query for entire list - result is not a dict + if {[string trim $p] eq ""} { + #review - multiple {[]} in a row in the path is pretty suspicious - raise error + error "tomlish::dict::path::exists error - multiple empty indices in a row not supported" + #or just leave data as is? + } else { + ::set intp [tomlish::system::lindex_resolve_basic $data $p] + if {$intp == -1} { + return 0 + } + ::set data [lindex $data $p] + } + } else { + if {![tomlish::dict::is_typeval $data]} { + return 0 + } + if {[dict get $data type] ne "ARRAY"} { + return 0 + } + #special case for empty path syntax {jq: [] path: ""} meaning retrieve all elements in list + ::set arrdata [dict get $data value] + if {[string trim $p] eq ""} { + #we have confirmed above it is an ARRAY - we consider an empty list to exist. + #UUU + ::set data $arrdata + } else { + #for 'exists' we need to avoid lindex returning empty string for out of bounds + ::set intp [tomlish::system::lindex_resolve_basic $arrdata $p] ;#handle index math (end-1 etc) + if {$intp == -1} { + #out of bounds + return 0 + } + ::set data [lindex $arrdata $p] + } } - if {[dict get $data type] ne "ARRAY"} { - return 0 + } + incr i + } + return $exists + } + + + #raise error for invalid + proc validate_typeval {typeval} { + set valtype [dict get $typeval type] + set rawval [dict get $typeval value] + switch -- $valtype { + INT { + if {![tomlish::utils::is_int $rawval]} { + return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml int: '$rawval'" } - ::set arrdata [dict get $data value] - ::set intp [tomlish::system::lindex_resolve_basic $arrdata $p] ;#handle index math (end-1 etc) - if {$intp == -1} { - #out of bounds - return 0 + } + BOOL { + #toml only accepts lower case true and false + #review + if {$rawval ni {true false}} { + return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml boolean (true|false): '$rawval'" + } + } + FLOAT { + if {![tomlish::utils::is_float $rawval]} { + return -code error -errorcode {TOML TYPE NOT_INT} "validate_typeval value is not a valid toml float: '$rawval'" + } + } + DATETIME { + #review - accept even when more specific types apply? + if {![tomlish::utils::is_datetime]} { + return -code error -errorcode {TOML TYPE NOT_DATETIME} "validate_typeval value is not a valid toml datetime: '$rawval'" + } + } + DATETIME-LOCAL { + if {![tomlish::utils::is_datetime-local]} { + return -code error -errorcode {TOML TYPE NOT_DATETIME-LOCAL} "validate_typeval value is not a valid toml datetime-local: '$rawval'" + } + } + DATE-LOCAL { + if {![tomlish::utils::is_date-local]} { + return -code error -errorcode {TOML TYPE NOT_DATE-LOCAL} "validate_typeval value is not a valid toml date-local: '$rawval'" + } + } + TIME-LOCAL { + if {![tomlish::utils::is_time-local]} { + return -code error -errorcode {TOML TYPE NOT_TIME-LOCAL} "validate_typeval value is not a valid toml time-local: '$rawval'" + } + } + ARRAY { + if {$rawval eq ""} { + return + } + foreach el $rawval { + validate_typeval $el + } + } + STRING { + if {![tomlish::utils::inner_Bstring_is_valid_toml $rawval]} { + return -code error -errorcode {TOML TYPE NOT_BSTRING} "validate_typeval value is not a valid toml basic string: '$rawval'" } - ::set data [lindex $arrdata $p] + } + MULTISTRING { + #multistring as a single value + #UUU + if {![tomlish::utils::inner_MultiBstring_is_valid_toml $rawval]} { + return -code error -errorcode {TOML TYPE NOT_MLBSTRING} "validate_typeval value is not a valid toml multistring: '$rawval'" + } + } + LITERAL { + #todo? + } + MULTILITERAL { + #? + } + default { + return -code error -errorcode {TOML TYPE UNRECOGNISED} "validate_typeval does not recognise type '$valtype'" } } - return $exists } #a restricted analogy of 'dictn set' - #set 'endpoints' - don't create intermediate paths + #set 'leaf' values only - don't create intermediate paths # can replace an existing dict with another dict # can create a key when key at tail end of path is a key (ie @@keyname, not index) # can replace an existing {type value value } # with added restriction that if is ARRAY the new must also be ARRAY - proc set_endpoint {dictvariable path value} { + + package require struct::list + proc setleaf {dictvariable path value {validate 1}} { + if {[string index $path 0] in [list . {[}]} { + set path [tomlish::utils::jq_to_path $path] + } + upvar $dictvariable dict_being_edited + if {![info exists dict_being_edited]} { + error "tomlish::dict::path::setleaf error - supplied value for 'dictvariable' doesn't seem to be the name of an existing variable" + } ::set data $dict_being_edited ::set pathsofar [list] if {!([tomlish::dict::is_typeval $value] || [tomlish::dict::is_typeval_dict $value 0])} { #failed check of supplied value as basic type, or a sub-dict structure (not checking arrays) - error "tomlish::dict::path::set_endpoint error - value must already be in the tomlish form {type value } or be a dict with such forms as leaves" + error "tomlish::dict::path::setleaf error - value must already be in the tomlish form {type value } or be a dict with such forms as leaves" + } + if {$validate && [tomlish::dict::is_typeval $value]} { + #validate value element of $value is correct for type element + if {[catch {validate_typeval $value} errM]} { + return -code error -errorcode {TOMLISH VALIDATION TYPEFAIL} $errM + } } foreach p $path { ::lappend pathsofar $p @@ -7759,28 +8767,28 @@ namespace eval tomlish::dict::path { #} ::set varname v[incr v] - if {$pathsofar eq $path} { - #see if endpoint of the path given already exists + if {[struct::list equal $pathsofar $path]} { + #see if leaf of the path given already exists if {[dict exists $data $k]} { ::set endpoint [dict get $data $k] if {[tomlish::dict::is_typeval $endpoint]} { set existing_tp [dict get $endpoint type] if {![tomlish::dict::is_typeval $value]} { - error "tomlish::dict::path::set_endpoint error Unable to overwrite subpath '$pathsofar' which is of type $existing_tp with sub-dict. Supplied value not {type value value val } with sub-dict: $value" + error "tomlish::dict::path::setleaf error path '$path'. Cannot overwrite {type val } with sub-dict: $value" } switch -- [dict get $endpoint type] { ARRAY { #disallow overwriting array - unless given value is an ARRAY? REVIEW if {[dict get $value type] ne "ARRAY"} { - error "tomlish::dict::path::set_endpoint error bad path '$path'. Cannot overwrite array with non-array: $value" + error "tomlish::dict::path::setleaf error bad path '$path'. Cannot overwrite array with non-array: $value" } } default { @@ -7831,9 +8839,9 @@ namespace eval tomlish::dict::path { } } } else { - #endpoint is a typeval dict not a plain typeval - only allow overwrite with a typeval dict + #leaf is a typeval dict not a plain typeval - only allow overwrite with a typeval dict if {![tomlish::dict::is_typeval_dict $value 0]} { - error "tomlish::dict::path::set_endpoint error path '$path'. Cannot overwrite sub-dict (size: [dict size $endpoint]) with non sub-dict: $value" + error "tomlish::dict::path::setleaf error path '$path'. Cannot overwrite sub-dict (size: [dict size $endpoint]) with non sub-dict: $value" } } ::set $varname $value @@ -7843,7 +8851,7 @@ namespace eval tomlish::dict::path { ::set arrdata [dict get $data value] set idx [tomlish::system::lindex_resolve_basic $arrdata $p] if {$idx == -1} { - error "tomlish::dict::path::set_endpoint error bad path '$path'. No existing element at $p" + error "tomlish::dict::path::setleaf error bad path '$path'. No existing element at $p" } ::set data [lindex $arrdata $p] ::set $varname $data @@ -7873,7 +8881,7 @@ namespace eval tomlish::dict::path { if {[string match @@* $k]} { #dict key #dict set $nextvarname $k $newval - set_endpoint $nextvarname [list $k] $newval + setleaf $nextvarname [list $k] $newval 0 } else { #list index ::set nextarr [dict get $nextval value] @@ -7889,6 +8897,9 @@ namespace eval tomlish::dict::path { #path must be to a {type ARRAY value } #REVIEW - how to lappend to deep mixed dict/array structure without rewriting whole datastructure? proc lappend {dictvariable path args} { + if {[string index $path 0] in [list . {[}]} { + set path [tomlish::utils::jq_to_path $path] + } upvar $dictvariable dict_being_edited ::set data $dict_being_edited ::set pathsofar [list] @@ -7896,7 +8907,7 @@ namespace eval tomlish::dict::path { ::set v 0 ::set vdict [dict create] foreach a $args { - if {![string is dict $a]} { + if {![::tomlish::utils::string_is_dict $a]} { error "tomlish::dict::path::lappend error - lappended arguments must already be in the tomlish form {type value } or be a dict with such forms as leaves" } } @@ -7909,7 +8920,7 @@ namespace eval tomlish::dict::path { } ::set varname v[incr v] - if {$pathsofar eq $path} { + if {[struct::list equal $pathsofar $path]} { #see if endpoint of the path given is an ARRAY ::set endpoint [dict get $data $k] if {![tomlish::dict::is_typeval $endpoint]} { @@ -7937,7 +8948,7 @@ namespace eval tomlish::dict::path { error "tomlish::dict::path::lappend error bad path $path. Subpath $pathsofar is not an array." } ::set varname v[incr v] - if {$pathsofar eq $path} { + if {[struct::list equal $pathsofar $path]} { if {[dict get $data type] ne "ARRAY"} { error "tomlish::dict::path::lappend error bad path $path. Parent path is not an array." } @@ -8136,6 +9147,8 @@ tcl::namespace::eval tomlish::app { #review chan configure $ch_input -translation lf + chan configure $ch_output -translation lf + if {[catch { set json [read $ch_input] }]} { @@ -8240,6 +9253,7 @@ namespace eval tomlish::system { #[para] For pure integer indices the performance should be equivalent set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 + #'only' supports 2**32 max index on tcl < 9.0 - ok. if {[string is integer -strict $index]} { #can match +i -i #avoid even the lseq overhead when the index is simple @@ -8266,6 +9280,25 @@ namespace eval tomlish::system { } } + #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features + #safe in that we don't evaluate the expression as a string. + proc offset_expr {expression} { + #required for tcl < 8.7 range command (lseq not available) + set expression [tcl::string::map {_ {}} $expression] + if {[tcl::string::is integer -strict $expression]} { + return [expr {$expression}] + } + if {[regexp {(.*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { + if {$op eq "-"} { + return [expr {$a - $b}] + } else { + return [expr {$a + $b}] + } + } else { + error "bad expression '$expression': must be integer?\[+-\]integer?" + } + } + if {[info commands ::lseq] ne ""} { #tcl 8.7+ lseq significantly faster, especially for larger ranges #The internal rep can be an 'arithseries' with no string representation