From d6d70a19ceaed7bbd7d5344ca70363fb6aaae90a Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Sun, 30 Nov 2025 01:26:55 +1100 Subject: [PATCH] bootsupport,vfs,project_layout catch up with module changess --- .../punk/args/moduledoc/tclcore-0.1.0.tm | 2 +- src/bootsupport/modules/punk/lib-0.1.5.tm | 389 +- .../punk/args/moduledoc/tclcore-0.1.0.tm | 2 +- .../src/bootsupport/modules/punk/lib-0.1.5.tm | 389 +- .../modules/punk/libunknown-0.1.tm | 8 +- .../bootsupport/modules/punk/repl-0.1.2.tm | 9 +- .../punk/args/moduledoc/tclcore-0.1.0.tm | 2 +- .../src/bootsupport/modules/punk/lib-0.1.5.tm | 389 +- .../modules/punk/libunknown-0.1.tm | 8 +- .../bootsupport/modules/punk/repl-0.1.2.tm | 9 +- .../_vfscommon.vfs/modules/punk/args-0.2.1.tm | 1 - .../punk/args/moduledoc/tclcore-0.1.0.tm | 2 +- .../modules/punk/console-0.1.1.tm | 28 +- .../modules/punk/imap4-0.9.1.tm | 4444 ++++++++ .../_vfscommon.vfs/modules/punk/lib-0.1.5.tm | 389 +- .../modules/punk/libunknown-0.1.tm | 8 +- .../modules/punk/netbox-0.1.1.tm | 3271 ++++++ .../modules/punk/netbox/man-0.1.0.tm | 147 + .../_vfscommon.vfs/modules/punk/repl-0.1.2.tm | 11 +- .../modules/shellfilter-0.2.1.tm | 28 +- .../modules/shellthread-1.6.2.tm | 58 +- .../_vfscommon.vfs/modules/tomlish-1.1.8.tm | 9489 +++++++++++++++++ 22 files changed, 18751 insertions(+), 332 deletions(-) create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.1.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/tomlish-1.1.8.tm diff --git a/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm b/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm index 004c790b..5623e7c9 100644 --- a/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm +++ b/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm @@ -8316,7 +8316,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { 4. If the end of the input string is reached before any conversions have been performed and no variables are given, an empty string is returned. } - @values -min 1 -max 2 + @values -min 2 -max 3 string -type string format -type string varName -type string -optional 1 -multiple 1 diff --git a/src/bootsupport/modules/punk/lib-0.1.5.tm b/src/bootsupport/modules/punk/lib-0.1.5.tm index a746058a..6b2dd8a9 100644 --- a/src/bootsupport/modules/punk/lib-0.1.5.tm +++ b/src/bootsupport/modules/punk/lib-0.1.5.tm @@ -174,6 +174,18 @@ tcl::namespace::eval punk::lib::check { set description "lsearch -stride with -subindices -inline -all and single index - incorrect results." return [dict create bug $bug bugref 5a1aaa201d description $description level major] } + proc has_tclbug_lseq_sign {} { + #https://core.tcl-lang.org/tcl/tktview/999b6966b2 + if {[catch {lseq 1 10}]} { + set bug 0 + } else { + set r1 [lseq 1 10 -9] + set r2 [lseq 1 10 -10] + set bug [expr {$r1 ne $r2}] + } + set description "lseq step sign not matching sequence direction - inconsistent results." + return [dict create bug $bug bugref 999b6966b2 description $description level minor] + } proc has_tclbug_list_quoting_emptyjoin {} { #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 @@ -827,23 +839,67 @@ namespace eval punk::lib { #tcl 8.7+ lseq significantly faster, especially for larger ranges #The internal rep can be an 'arithseries' with no string representation #support minimal set from to - proc range {from to} { - lseq $from $to + proc range {from to {by 1}} { + #note inconsistency with lseq 1 10 by -9 vs lseq 1 10 by -10 + #https://core.tcl-lang.org/tcl/tktview/999b6966b2 + lseq $from $to by $by } } else { #lseq accepts basic expressions e.g 4-2 for both arguments #e.g we can do lseq 0 [llength $list]-1 #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. - proc range {from to} { + #our range function doesn't support double like lseq does. (deliberate) review + proc range {from to {by ""}} { + if {$by eq "0"} { + #as per lseq, step (by) zero always gives no result + return [list] + } set to [offset_expr $to] set from [offset_expr $from] + if {$by ne ""} { + set by [offset_expr $by] + } + #assert $by is now empty string or an integer if {$to > $from} { - set count [expr {($to -$from) + 1}] - if {$from == 0} { - return [lsearch -all [lrepeat $count 0] *] - } else { - incr from -1 - return [lmap v [lrepeat $count 0] {incr from}] + switch -- $by { + "" - 1 { + set count [expr {($to -$from) + 1}] + if {$from == 0} { + return [lsearch -all [lrepeat $count 0] *] + } else { + incr from -1 + return [lmap v [lrepeat $count 0] {incr from}] + } + } + default { + set count [expr {($to - $from + $by) / $by}] + if {$count <= 0} { + #return [list] + #https://core.tcl-lang.org/tcl/tktview/999b6966b2 + return [list $from] ;#review + } + set result [list] + for {set i $from} {$i <= $to} {incr i $by} { + lappend result $i + } + return $result + + #if we don't have lseq, we probably don't have lsearch -stride, which would make things simpler. + #set count [expr {($to -$from) + 1}] + #if {$from == 0} { + # set fullrange [lsearch -all [lrepeat $count 0] *] + #} else { + # incr from -1 + # set fullrange [lmap v [lrepeat $count 0] {incr from}] + #} + #set result [list] + #for {set i 0} {$i < $count} {incr i} { + # if {$i % $by == 0} { + # lappend result [lindex $fullrange $i] + # } + #} + #return $result + } } #slower methods. #2) @@ -858,13 +914,28 @@ namespace eval punk::lib { #} #return $L } elseif {$from > $to} { - set count [expr {$from - $to} + 1] - #1) - if {$to == 0} { - return [lreverse [lsearch -all [lrepeat $count 0] *]] - } else { - incr from - return [lmap v [lrepeat $count 0] {incr from -1}] + switch -- $by { + "" - -1 { + set count [expr {$from - $to} + 1] + if {$to == 0} { + return [lreverse [lsearch -all [lrepeat $count 0] *]] + } else { + incr from + return [lmap v [lrepeat $count 0] {incr from -1}] + } + } + default { + set count [expr {($to - $from + $by) / $by}] + if {$count <= 0} { + #return [list] + return [list $from] ;#review + } + set result [list] + for {set i $from} {$i >= $to} {incr i $by} { + lappend result $i + } + return $result + } } #2) @@ -2468,7 +2539,7 @@ namespace eval punk::lib { #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} { - set expression [tcl::string::map {_ {}} $expression] + set expression [tcl::string::map {_ {}} $expression] ;#review - this is for 8.6 to understand underscored ints if {[tcl::string::is integer -strict $expression]} { return [expr {$expression}] } @@ -2531,22 +2602,35 @@ namespace eval punk::lib { if {$rposn >= 0} { set sepsize 2 set step 1 - } else { + #review - whitespace between ints? + lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + } elseif {[string first . $r] >= 0} { + set stripped [string map {. ""} $r] + if {[tcl::string::length $stripped] != [tcl::string::length $r]-2} { + #if one dot exists - must be exactly 2 dots in total - possibly separated by positive/negative int (not zero) + return 0 + } + #assert - we have exactly 2 dots separated by something. #check for .n. 'stepped' range set fdot [string first . $r] set ldot [string last . $r] set step [string range $r $fdot+1 $ldot-1] #todo - allow basic mathops for step: 2+1 2+-1 etc same as tcl lindex, lseq - if {![string is integer -strict $step]} { - } - } + #1.0.10 should be valid but behave similarly to lseq 1 0 by 0 ie returns nothing - if {$rposn >= 0} { - lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + #1.end.10 or similar shouldn't be valid - but we need to allow other basic index expressions. + if {[string match *end* $step] || [catch {lindex {} $step}]} { + return 0 + } + #if {![string is integer -strict $step] || $step == 0} { + # return 0 + #} + lappend validateindices {*}[string range $r 0 $fdot-1] {*}[string range $r $ldot+1 end] } else { #'range' is just an index set validateindices [list $r] } + foreach v $validateindices { if {$v eq "" || $v eq "end"} {continue} if {[string is integer -strict $v]} {continue} @@ -2558,6 +2642,7 @@ namespace eval punk::lib { return 1 } #review - compare to IMAP4 methods of specifying ranges? + #TODO add tests to test::punk::lib indexset_resolve is a little tricky punk::args::define { @id -id ::punk::lib::indexset_resolve @cmd -name punk::lib::indexset_resolve\ @@ -2568,13 +2653,44 @@ namespace eval punk::lib { e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9 An indexset consists of a comma delimited list of indexes or index-ranges. - Ranges must be specified with .. as the separator, with an empty value at either side of the - separator representing beginning and end of the index range respectively. + Ranges must be specified with a range-indicator such as .. as the separator, with an empty value at + either side of the separator representing beginning and end of the index range respectively. + The range-separator can be of the form .x. where x is an integer or basic expression + (single +/- operation) that indicates the step value to use. This is equivalent to the 'by' value + in the tcl9 lseq command. + + When the start index is lower than the end, the step value defaults to 1. + ie indexset_resolve 0..7 is equivalent to indexset_resolve 0.1.7 + When the start index is higher than the end, the step value defaults to -1. + ie indexset_resolve 7..0 is equivalent to indexset_resolve 0.-1.7 + + If start and end are ommitted, increasing order is assumed if the step isn't specified. + eg + .. represents the range from the base to the end + .-1. would represent end to base with step -1 + + If start is omitted and only the end is supplied: + The default step is 1 indicating ascension and the missing end is equivalent to 'end' + indexset_resolve 5 2.. + -> 2 3 4 + The default end is the base if the step is negative + indexset_resolve 5 2.-1. + -> 2 1 0 + If end is omitted and onlthe start is supplied: + The default step is 1 indicating ascension and the missing start is equivalent to the base. + indexset_resolve 5 ..2 + -> 0 1 2 + The default start is 'end' if the step is negative + indexset_resolve 5 .-1.2 + -> 4 3 2 + + + Like the tcl9 lseq command - a step (by) value of zero produces no results. The indexes are 0-based by default, but the base can be specified. indexset_resolve 7 .. -> 0 1 2 3 4 5 6 - indexset_resolve 7 .. -3 + indexset_resolve -base -3 7 .. -> -3 -2 -1 0 1 2 3 Whitespace is ignored. @@ -2599,10 +2715,9 @@ namespace eval punk::lib { output the first 3 indices, and the last index. end-1..0 output the indexes in reverse order from 2nd last item to first item." - @values -min 2 -max 3 - numitems -type integer - indexset -type indexset -help "comma delimited specification for indices to return" - base -type integer -default 0 -help\ + @leaders -min 0 -max 0 + @opts + -base -type integer -prefix 1 -default 0 -help\ "This is the starting index. It can be positive, negative or zero. This affects the start and end calculations, limiting what indices will be returned. @@ -2613,73 +2728,175 @@ namespace eval punk::lib { For base 1, index 0 is considered to be below the range. ie - indexset_resolve 10 0..3 1 + indexset_resolve -base 1 10 0..3 -> 1 2 3 - indexset_resolve 10 0..3 0 + indexset_resolve -base 0 10 0..3 -> 0 1 2 3 - It does not *convert* integers within the range. + It does not *convert* indexes within the range. - indexset_resolve 10 5 1 + indexset_resolve -base 1 10 5 -> 5 - indexset_resolve 10 5 0 + indexset_resolve -base 0 10 5 -> 5 - ie if you ask for a 1 based indexset the integers that are within the - range will come out the same, so the result needs to be treated as a - 1-based set of indices when performing further operations. + ie if you ask for a 1-based resolution of an indexset the integers that are within + the range will come out the same, so the result needs to be treated as a 1-based + set of indices when performing further operations. " + @values -min 2 -max 3 + numitems -type integer + indexset -type indexset -help "comma delimited specification for indices to return" } - proc indexset_resolve {numitems indexset {base 0}} { + + #limit punk::args parsing to unhappy paths where possible + proc indexset_resolve {args} { + # -------------------------------------------------- + # Manual parsing of happy path args instead of using punk::args::parse $args withid ::punk::lib::indexset_resolve + # This is because indexset_resolve is *somewhat* low level, has only a few args, and we don't want any overhead. + # for the unhappy path - the punk::args::parse is fine to generate the usage/error information. + # -------------------------------------------------- + if {[llength $args] < 2} { + punk::args::resolve $args withid ::punk::lib::indexset_resolve + } + set indexset [lindex $args end] + set numitems [lindex $args end-1] if {![string is integer -strict $numitems] || ![is_indexset $indexset]} { #use parser on unhappy path only set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] } + #assert we have 2 or more args + set base 0 ;#default + if {[llength $args] > 2} { + #if more than just numitems and indexset - we expect only -base ie 4 args in total + if {[llength $args] != 4} { + set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] + } + set optname [lindex $args 0] + set optval [lindex $args 1] + set fulloptname [tcl::prefix::match -error "" -base $optname] + if {$fulloptname ne "-base" || ![string is integer -strict $optval]} { + set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] + } + set base $optval + } + # -------------------------------------------------- + + set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace set index_list [list] ;#list of actual indexes within the range set iparts [split $indexset ,] set based_max [expr {$numitems -1 + $base}] + #we already did is_indexset check above, so we can make assumptions about well-formedness of each part foreach ipart $iparts { set ipart [string trim $ipart] - set rposn [string first .. $ipart] + #we need to cater for n..m as well as n.s.m where s is 'step' + set rposn [string first . $ipart] if {$rposn>=0} { - #range - lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb - set rawa [string trim $rawa] - set rawb [string trim $rawb] - if {$rawa eq ""} {set rawa $base} - set a [punk::lib::lindex_resolve $numitems $rawa $base] - if {$a == -Inf} { - #(was -3) - #undershot - leave negative - } elseif {$a == Inf} { - #overshot - set a [expr {$based_max + 1}] ;#put it outside the range on the upper side + #if we found one dot - there must be exactly 2 dots in the ipart, separated by nothing, or a basic integer-expression + set rposn2 [string last . $ipart] + if {$rposn2 == $rposn+1} { + #.. + set step "default" ;#could be 1 or -1 + } else { + set step [tcl::string::range $ipart $rposn+1 $rposn2-1] } - #review - a may be -Inf + lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn2+1] rawa _ rawb - if {$rawb eq ""} { - if {$a > $based_max} { - set rawb $a ;#make sure .. doesn't return last item - should return nothing + set rawa [string trim $rawa] + set rawb [string trim $rawb] + if {$rawa eq "" && $rawb eq ""} { + if {$step eq "default"} { + set step 1 ;#default ascending when no start and no end + } + if {$step < 0} { + set rawa end + set rawb $base } else { + set rawa $base set rawb end } - } - set b [punk::lib::lindex_resolve $numitems $rawb $base] - if {$b == -Inf} { - #undershot - leave negative - } elseif {$b == Inf} { - #set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side - set b [expr {$based_max + 1}] ;#overshot - put it outside the range on the upper side + #if neither start nor end specified - we won't get out of range results from lindex_resolve + set a [punk::lib::lindex_resolve $numitems $rawa $base] + set b [punk::lib::lindex_resolve $numitems $rawb $base] + } else { + if {$rawa eq ""} { + if {$step eq "default"} { + #when start not specified, but end is - default direction always ascending + #(even if end is base or below range) + set step 1 + } + if {$step < 0} { + set rawa end + } else { + set rawa $base + } + } + set a [punk::lib::lindex_resolve $numitems $rawa $base] + if {$a == -Inf} { + #undershot - leave negative + } elseif {$a == Inf} { + #overshot + set a [expr {$based_max + 1}] ;#put it outside the range on the upper side + } + #review - a may be -Inf + + if {$rawb eq ""} { + if {$step eq "default"} { + set step 1 + } + if {$step < 0} { + if {$a < $base} { + #make sure both + #mathfunc::isinf is tcl9+ + if {[catch { + if {[::tcl::mathfunc::isinf $a]} { + set a [expr {$base -1}] + } + }]} { + if {[string match -nocase *inf* $a]} { + set a [expr {$base -1}] + } + } + set rawb $a + } else { + set rawb $base + } + } else { + if {$a > $based_max} { + set rawb $a ;#make sure .. doesn't return last item - should return nothing + } else { + set rawb end + } + } + } + set b [punk::lib::lindex_resolve $numitems $rawb $base] + if {$b == -Inf} { + #undershot - leave negative + } elseif {$b == Inf} { + #set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side + set b [expr {$based_max + 1}] ;#overshot - put it outside the range on the upper side + } } #JJJ #e.g make sure .. doesn't return last item - should return nothing as both are above the range. if {$a >= $base && $a <= $based_max && $b >=$base && $b <= $based_max} { - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + #assert a & b are integers within the range + if {$step eq "default"} { + #unspecified step - base direction on order of a & b + if {$a <= $b} { + set step 1 + } else { + set step -1 + } + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } else { if {$a >= $base && $a <= $based_max} { #only a is in the range @@ -2688,27 +2905,57 @@ namespace eval punk::lib { } else { set b $based_max } - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + if {$step eq "default"} { + if {$a <= $b} { + set step 1 + } else { + set step -1 + } + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } elseif {$b >=$base && $b <= $based_max} { #only b is in the range - if {$a < $base} { - set a $base + if {$step eq "default"} { + if {$a <= $b} { + set step 1 + } else { + set step -1 + } + } + if {$step < 0} { + if {$a < $base} { + #negative step from below - doesn't matter if b is in range - recast both to an int below $base + #(a may be -Inf) + set a [expr {$base -1}] + set b $a + set step 0 ;#we should return nothing + } } else { - set a $based_max + if {$a < $base} { + set a $base + } else { + set a $based_max + } } - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } else { #both outside the range if {$a < $base && $b > $base} { #spans the range in forward order set a $base set b $based_max - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + if {$step eq "default"} { + set step 1 + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } elseif {$a > $base && $b < $base} { #spans the range in reverse order set a $based_max set b $base - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + if {$step eq "default"} { + set step -1 + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } #both outside of range on same side } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm index 004c790b..5623e7c9 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm @@ -8316,7 +8316,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { 4. If the end of the input string is reached before any conversions have been performed and no variables are given, an empty string is returned. } - @values -min 1 -max 2 + @values -min 2 -max 3 string -type string format -type string varName -type string -optional 1 -multiple 1 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm index a746058a..6b2dd8a9 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm @@ -174,6 +174,18 @@ tcl::namespace::eval punk::lib::check { set description "lsearch -stride with -subindices -inline -all and single index - incorrect results." return [dict create bug $bug bugref 5a1aaa201d description $description level major] } + proc has_tclbug_lseq_sign {} { + #https://core.tcl-lang.org/tcl/tktview/999b6966b2 + if {[catch {lseq 1 10}]} { + set bug 0 + } else { + set r1 [lseq 1 10 -9] + set r2 [lseq 1 10 -10] + set bug [expr {$r1 ne $r2}] + } + set description "lseq step sign not matching sequence direction - inconsistent results." + return [dict create bug $bug bugref 999b6966b2 description $description level minor] + } proc has_tclbug_list_quoting_emptyjoin {} { #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 @@ -827,23 +839,67 @@ namespace eval punk::lib { #tcl 8.7+ lseq significantly faster, especially for larger ranges #The internal rep can be an 'arithseries' with no string representation #support minimal set from to - proc range {from to} { - lseq $from $to + proc range {from to {by 1}} { + #note inconsistency with lseq 1 10 by -9 vs lseq 1 10 by -10 + #https://core.tcl-lang.org/tcl/tktview/999b6966b2 + lseq $from $to by $by } } else { #lseq accepts basic expressions e.g 4-2 for both arguments #e.g we can do lseq 0 [llength $list]-1 #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. - proc range {from to} { + #our range function doesn't support double like lseq does. (deliberate) review + proc range {from to {by ""}} { + if {$by eq "0"} { + #as per lseq, step (by) zero always gives no result + return [list] + } set to [offset_expr $to] set from [offset_expr $from] + if {$by ne ""} { + set by [offset_expr $by] + } + #assert $by is now empty string or an integer if {$to > $from} { - set count [expr {($to -$from) + 1}] - if {$from == 0} { - return [lsearch -all [lrepeat $count 0] *] - } else { - incr from -1 - return [lmap v [lrepeat $count 0] {incr from}] + switch -- $by { + "" - 1 { + set count [expr {($to -$from) + 1}] + if {$from == 0} { + return [lsearch -all [lrepeat $count 0] *] + } else { + incr from -1 + return [lmap v [lrepeat $count 0] {incr from}] + } + } + default { + set count [expr {($to - $from + $by) / $by}] + if {$count <= 0} { + #return [list] + #https://core.tcl-lang.org/tcl/tktview/999b6966b2 + return [list $from] ;#review + } + set result [list] + for {set i $from} {$i <= $to} {incr i $by} { + lappend result $i + } + return $result + + #if we don't have lseq, we probably don't have lsearch -stride, which would make things simpler. + #set count [expr {($to -$from) + 1}] + #if {$from == 0} { + # set fullrange [lsearch -all [lrepeat $count 0] *] + #} else { + # incr from -1 + # set fullrange [lmap v [lrepeat $count 0] {incr from}] + #} + #set result [list] + #for {set i 0} {$i < $count} {incr i} { + # if {$i % $by == 0} { + # lappend result [lindex $fullrange $i] + # } + #} + #return $result + } } #slower methods. #2) @@ -858,13 +914,28 @@ namespace eval punk::lib { #} #return $L } elseif {$from > $to} { - set count [expr {$from - $to} + 1] - #1) - if {$to == 0} { - return [lreverse [lsearch -all [lrepeat $count 0] *]] - } else { - incr from - return [lmap v [lrepeat $count 0] {incr from -1}] + switch -- $by { + "" - -1 { + set count [expr {$from - $to} + 1] + if {$to == 0} { + return [lreverse [lsearch -all [lrepeat $count 0] *]] + } else { + incr from + return [lmap v [lrepeat $count 0] {incr from -1}] + } + } + default { + set count [expr {($to - $from + $by) / $by}] + if {$count <= 0} { + #return [list] + return [list $from] ;#review + } + set result [list] + for {set i $from} {$i >= $to} {incr i $by} { + lappend result $i + } + return $result + } } #2) @@ -2468,7 +2539,7 @@ namespace eval punk::lib { #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} { - set expression [tcl::string::map {_ {}} $expression] + set expression [tcl::string::map {_ {}} $expression] ;#review - this is for 8.6 to understand underscored ints if {[tcl::string::is integer -strict $expression]} { return [expr {$expression}] } @@ -2531,22 +2602,35 @@ namespace eval punk::lib { if {$rposn >= 0} { set sepsize 2 set step 1 - } else { + #review - whitespace between ints? + lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + } elseif {[string first . $r] >= 0} { + set stripped [string map {. ""} $r] + if {[tcl::string::length $stripped] != [tcl::string::length $r]-2} { + #if one dot exists - must be exactly 2 dots in total - possibly separated by positive/negative int (not zero) + return 0 + } + #assert - we have exactly 2 dots separated by something. #check for .n. 'stepped' range set fdot [string first . $r] set ldot [string last . $r] set step [string range $r $fdot+1 $ldot-1] #todo - allow basic mathops for step: 2+1 2+-1 etc same as tcl lindex, lseq - if {![string is integer -strict $step]} { - } - } + #1.0.10 should be valid but behave similarly to lseq 1 0 by 0 ie returns nothing - if {$rposn >= 0} { - lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + #1.end.10 or similar shouldn't be valid - but we need to allow other basic index expressions. + if {[string match *end* $step] || [catch {lindex {} $step}]} { + return 0 + } + #if {![string is integer -strict $step] || $step == 0} { + # return 0 + #} + lappend validateindices {*}[string range $r 0 $fdot-1] {*}[string range $r $ldot+1 end] } else { #'range' is just an index set validateindices [list $r] } + foreach v $validateindices { if {$v eq "" || $v eq "end"} {continue} if {[string is integer -strict $v]} {continue} @@ -2558,6 +2642,7 @@ namespace eval punk::lib { return 1 } #review - compare to IMAP4 methods of specifying ranges? + #TODO add tests to test::punk::lib indexset_resolve is a little tricky punk::args::define { @id -id ::punk::lib::indexset_resolve @cmd -name punk::lib::indexset_resolve\ @@ -2568,13 +2653,44 @@ namespace eval punk::lib { e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9 An indexset consists of a comma delimited list of indexes or index-ranges. - Ranges must be specified with .. as the separator, with an empty value at either side of the - separator representing beginning and end of the index range respectively. + Ranges must be specified with a range-indicator such as .. as the separator, with an empty value at + either side of the separator representing beginning and end of the index range respectively. + The range-separator can be of the form .x. where x is an integer or basic expression + (single +/- operation) that indicates the step value to use. This is equivalent to the 'by' value + in the tcl9 lseq command. + + When the start index is lower than the end, the step value defaults to 1. + ie indexset_resolve 0..7 is equivalent to indexset_resolve 0.1.7 + When the start index is higher than the end, the step value defaults to -1. + ie indexset_resolve 7..0 is equivalent to indexset_resolve 0.-1.7 + + If start and end are ommitted, increasing order is assumed if the step isn't specified. + eg + .. represents the range from the base to the end + .-1. would represent end to base with step -1 + + If start is omitted and only the end is supplied: + The default step is 1 indicating ascension and the missing end is equivalent to 'end' + indexset_resolve 5 2.. + -> 2 3 4 + The default end is the base if the step is negative + indexset_resolve 5 2.-1. + -> 2 1 0 + If end is omitted and onlthe start is supplied: + The default step is 1 indicating ascension and the missing start is equivalent to the base. + indexset_resolve 5 ..2 + -> 0 1 2 + The default start is 'end' if the step is negative + indexset_resolve 5 .-1.2 + -> 4 3 2 + + + Like the tcl9 lseq command - a step (by) value of zero produces no results. The indexes are 0-based by default, but the base can be specified. indexset_resolve 7 .. -> 0 1 2 3 4 5 6 - indexset_resolve 7 .. -3 + indexset_resolve -base -3 7 .. -> -3 -2 -1 0 1 2 3 Whitespace is ignored. @@ -2599,10 +2715,9 @@ namespace eval punk::lib { output the first 3 indices, and the last index. end-1..0 output the indexes in reverse order from 2nd last item to first item." - @values -min 2 -max 3 - numitems -type integer - indexset -type indexset -help "comma delimited specification for indices to return" - base -type integer -default 0 -help\ + @leaders -min 0 -max 0 + @opts + -base -type integer -prefix 1 -default 0 -help\ "This is the starting index. It can be positive, negative or zero. This affects the start and end calculations, limiting what indices will be returned. @@ -2613,73 +2728,175 @@ namespace eval punk::lib { For base 1, index 0 is considered to be below the range. ie - indexset_resolve 10 0..3 1 + indexset_resolve -base 1 10 0..3 -> 1 2 3 - indexset_resolve 10 0..3 0 + indexset_resolve -base 0 10 0..3 -> 0 1 2 3 - It does not *convert* integers within the range. + It does not *convert* indexes within the range. - indexset_resolve 10 5 1 + indexset_resolve -base 1 10 5 -> 5 - indexset_resolve 10 5 0 + indexset_resolve -base 0 10 5 -> 5 - ie if you ask for a 1 based indexset the integers that are within the - range will come out the same, so the result needs to be treated as a - 1-based set of indices when performing further operations. + ie if you ask for a 1-based resolution of an indexset the integers that are within + the range will come out the same, so the result needs to be treated as a 1-based + set of indices when performing further operations. " + @values -min 2 -max 3 + numitems -type integer + indexset -type indexset -help "comma delimited specification for indices to return" } - proc indexset_resolve {numitems indexset {base 0}} { + + #limit punk::args parsing to unhappy paths where possible + proc indexset_resolve {args} { + # -------------------------------------------------- + # Manual parsing of happy path args instead of using punk::args::parse $args withid ::punk::lib::indexset_resolve + # This is because indexset_resolve is *somewhat* low level, has only a few args, and we don't want any overhead. + # for the unhappy path - the punk::args::parse is fine to generate the usage/error information. + # -------------------------------------------------- + if {[llength $args] < 2} { + punk::args::resolve $args withid ::punk::lib::indexset_resolve + } + set indexset [lindex $args end] + set numitems [lindex $args end-1] if {![string is integer -strict $numitems] || ![is_indexset $indexset]} { #use parser on unhappy path only set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] } + #assert we have 2 or more args + set base 0 ;#default + if {[llength $args] > 2} { + #if more than just numitems and indexset - we expect only -base ie 4 args in total + if {[llength $args] != 4} { + set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] + } + set optname [lindex $args 0] + set optval [lindex $args 1] + set fulloptname [tcl::prefix::match -error "" -base $optname] + if {$fulloptname ne "-base" || ![string is integer -strict $optval]} { + set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] + } + set base $optval + } + # -------------------------------------------------- + + set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace set index_list [list] ;#list of actual indexes within the range set iparts [split $indexset ,] set based_max [expr {$numitems -1 + $base}] + #we already did is_indexset check above, so we can make assumptions about well-formedness of each part foreach ipart $iparts { set ipart [string trim $ipart] - set rposn [string first .. $ipart] + #we need to cater for n..m as well as n.s.m where s is 'step' + set rposn [string first . $ipart] if {$rposn>=0} { - #range - lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb - set rawa [string trim $rawa] - set rawb [string trim $rawb] - if {$rawa eq ""} {set rawa $base} - set a [punk::lib::lindex_resolve $numitems $rawa $base] - if {$a == -Inf} { - #(was -3) - #undershot - leave negative - } elseif {$a == Inf} { - #overshot - set a [expr {$based_max + 1}] ;#put it outside the range on the upper side + #if we found one dot - there must be exactly 2 dots in the ipart, separated by nothing, or a basic integer-expression + set rposn2 [string last . $ipart] + if {$rposn2 == $rposn+1} { + #.. + set step "default" ;#could be 1 or -1 + } else { + set step [tcl::string::range $ipart $rposn+1 $rposn2-1] } - #review - a may be -Inf + lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn2+1] rawa _ rawb - if {$rawb eq ""} { - if {$a > $based_max} { - set rawb $a ;#make sure .. doesn't return last item - should return nothing + set rawa [string trim $rawa] + set rawb [string trim $rawb] + if {$rawa eq "" && $rawb eq ""} { + if {$step eq "default"} { + set step 1 ;#default ascending when no start and no end + } + if {$step < 0} { + set rawa end + set rawb $base } else { + set rawa $base set rawb end } - } - set b [punk::lib::lindex_resolve $numitems $rawb $base] - if {$b == -Inf} { - #undershot - leave negative - } elseif {$b == Inf} { - #set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side - set b [expr {$based_max + 1}] ;#overshot - put it outside the range on the upper side + #if neither start nor end specified - we won't get out of range results from lindex_resolve + set a [punk::lib::lindex_resolve $numitems $rawa $base] + set b [punk::lib::lindex_resolve $numitems $rawb $base] + } else { + if {$rawa eq ""} { + if {$step eq "default"} { + #when start not specified, but end is - default direction always ascending + #(even if end is base or below range) + set step 1 + } + if {$step < 0} { + set rawa end + } else { + set rawa $base + } + } + set a [punk::lib::lindex_resolve $numitems $rawa $base] + if {$a == -Inf} { + #undershot - leave negative + } elseif {$a == Inf} { + #overshot + set a [expr {$based_max + 1}] ;#put it outside the range on the upper side + } + #review - a may be -Inf + + if {$rawb eq ""} { + if {$step eq "default"} { + set step 1 + } + if {$step < 0} { + if {$a < $base} { + #make sure both + #mathfunc::isinf is tcl9+ + if {[catch { + if {[::tcl::mathfunc::isinf $a]} { + set a [expr {$base -1}] + } + }]} { + if {[string match -nocase *inf* $a]} { + set a [expr {$base -1}] + } + } + set rawb $a + } else { + set rawb $base + } + } else { + if {$a > $based_max} { + set rawb $a ;#make sure .. doesn't return last item - should return nothing + } else { + set rawb end + } + } + } + set b [punk::lib::lindex_resolve $numitems $rawb $base] + if {$b == -Inf} { + #undershot - leave negative + } elseif {$b == Inf} { + #set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side + set b [expr {$based_max + 1}] ;#overshot - put it outside the range on the upper side + } } #JJJ #e.g make sure .. doesn't return last item - should return nothing as both are above the range. if {$a >= $base && $a <= $based_max && $b >=$base && $b <= $based_max} { - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + #assert a & b are integers within the range + if {$step eq "default"} { + #unspecified step - base direction on order of a & b + if {$a <= $b} { + set step 1 + } else { + set step -1 + } + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } else { if {$a >= $base && $a <= $based_max} { #only a is in the range @@ -2688,27 +2905,57 @@ namespace eval punk::lib { } else { set b $based_max } - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + if {$step eq "default"} { + if {$a <= $b} { + set step 1 + } else { + set step -1 + } + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } elseif {$b >=$base && $b <= $based_max} { #only b is in the range - if {$a < $base} { - set a $base + if {$step eq "default"} { + if {$a <= $b} { + set step 1 + } else { + set step -1 + } + } + if {$step < 0} { + if {$a < $base} { + #negative step from below - doesn't matter if b is in range - recast both to an int below $base + #(a may be -Inf) + set a [expr {$base -1}] + set b $a + set step 0 ;#we should return nothing + } } else { - set a $based_max + if {$a < $base} { + set a $base + } else { + set a $based_max + } } - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } else { #both outside the range if {$a < $base && $b > $base} { #spans the range in forward order set a $base set b $based_max - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + if {$step eq "default"} { + set step 1 + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } elseif {$a > $base && $b < $base} { #spans the range in reverse order set a $based_max set b $base - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + if {$step eq "default"} { + set step -1 + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } #both outside of range on same side } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm index fea6b146..d7eaf639 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -62,7 +62,7 @@ package require Tcl 8.6- -tcl::namespace::eval punk::libunknown { +tcl::namespace::eval ::punk::libunknown { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -1576,7 +1576,7 @@ tcl::namespace::eval punk::libunknown { } # == === === === === === === === === === === === === === === -namespace eval punk::libunknown { +namespace eval ::punk::libunknown { #for 8.6 compat if {"::ledit" ni [info commands ::ledit]} { #maint: taken from punk::lib @@ -1702,7 +1702,7 @@ namespace eval punk::libunknown { } } -tcl::namespace::eval punk::libunknown::lib { +tcl::namespace::eval ::punk::libunknown::lib { #A version of textutil::string::longestCommonPrefixList #(also as ::punk::lib::longestCommonPrefixList) @@ -1788,7 +1788,7 @@ namespace eval ::punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready -package provide punk::libunknown [tcl::namespace::eval punk::libunknown { +package provide punk::libunknown [tcl::namespace::eval ::punk::libunknown { variable pkg punk::libunknown variable version set version 0.1 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index 30941f83..96f506b5 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -52,7 +52,10 @@ if {[package provide punk::libunknown] eq ""} { if {$libunknown ne ""} { uplevel 1 [list source $libunknown] if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { - puts "error initialising punk::libunknown\n$errM" + puts stderr "error initialising punk::libunknown during punk::repl package load of script [info script]" + puts stderr "sourcing from: $libunknown" + puts stderr "tcl::tm::list: [tcl::tm::list]" + puts stderr $errM } } }} @@ -3593,7 +3596,9 @@ namespace eval repl { if {$libunknown ne ""} { uplevel 1 [list ::source $libunknown] if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { - puts "error initialising punk::libunknown\n$errM" + puts stderr "error initialising punk::libunknown\n from: '$libunknown'" + puts stderr "tcl::tm::list: [tcl::tm::list]" + puts stderr "error: $errM" } } }} diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm index 004c790b..5623e7c9 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm @@ -8316,7 +8316,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { 4. If the end of the input string is reached before any conversions have been performed and no variables are given, an empty string is returned. } - @values -min 1 -max 2 + @values -min 2 -max 3 string -type string format -type string varName -type string -optional 1 -multiple 1 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm index a746058a..6b2dd8a9 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm @@ -174,6 +174,18 @@ tcl::namespace::eval punk::lib::check { set description "lsearch -stride with -subindices -inline -all and single index - incorrect results." return [dict create bug $bug bugref 5a1aaa201d description $description level major] } + proc has_tclbug_lseq_sign {} { + #https://core.tcl-lang.org/tcl/tktview/999b6966b2 + if {[catch {lseq 1 10}]} { + set bug 0 + } else { + set r1 [lseq 1 10 -9] + set r2 [lseq 1 10 -10] + set bug [expr {$r1 ne $r2}] + } + set description "lseq step sign not matching sequence direction - inconsistent results." + return [dict create bug $bug bugref 999b6966b2 description $description level minor] + } proc has_tclbug_list_quoting_emptyjoin {} { #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 @@ -827,23 +839,67 @@ namespace eval punk::lib { #tcl 8.7+ lseq significantly faster, especially for larger ranges #The internal rep can be an 'arithseries' with no string representation #support minimal set from to - proc range {from to} { - lseq $from $to + proc range {from to {by 1}} { + #note inconsistency with lseq 1 10 by -9 vs lseq 1 10 by -10 + #https://core.tcl-lang.org/tcl/tktview/999b6966b2 + lseq $from $to by $by } } else { #lseq accepts basic expressions e.g 4-2 for both arguments #e.g we can do lseq 0 [llength $list]-1 #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. - proc range {from to} { + #our range function doesn't support double like lseq does. (deliberate) review + proc range {from to {by ""}} { + if {$by eq "0"} { + #as per lseq, step (by) zero always gives no result + return [list] + } set to [offset_expr $to] set from [offset_expr $from] + if {$by ne ""} { + set by [offset_expr $by] + } + #assert $by is now empty string or an integer if {$to > $from} { - set count [expr {($to -$from) + 1}] - if {$from == 0} { - return [lsearch -all [lrepeat $count 0] *] - } else { - incr from -1 - return [lmap v [lrepeat $count 0] {incr from}] + switch -- $by { + "" - 1 { + set count [expr {($to -$from) + 1}] + if {$from == 0} { + return [lsearch -all [lrepeat $count 0] *] + } else { + incr from -1 + return [lmap v [lrepeat $count 0] {incr from}] + } + } + default { + set count [expr {($to - $from + $by) / $by}] + if {$count <= 0} { + #return [list] + #https://core.tcl-lang.org/tcl/tktview/999b6966b2 + return [list $from] ;#review + } + set result [list] + for {set i $from} {$i <= $to} {incr i $by} { + lappend result $i + } + return $result + + #if we don't have lseq, we probably don't have lsearch -stride, which would make things simpler. + #set count [expr {($to -$from) + 1}] + #if {$from == 0} { + # set fullrange [lsearch -all [lrepeat $count 0] *] + #} else { + # incr from -1 + # set fullrange [lmap v [lrepeat $count 0] {incr from}] + #} + #set result [list] + #for {set i 0} {$i < $count} {incr i} { + # if {$i % $by == 0} { + # lappend result [lindex $fullrange $i] + # } + #} + #return $result + } } #slower methods. #2) @@ -858,13 +914,28 @@ namespace eval punk::lib { #} #return $L } elseif {$from > $to} { - set count [expr {$from - $to} + 1] - #1) - if {$to == 0} { - return [lreverse [lsearch -all [lrepeat $count 0] *]] - } else { - incr from - return [lmap v [lrepeat $count 0] {incr from -1}] + switch -- $by { + "" - -1 { + set count [expr {$from - $to} + 1] + if {$to == 0} { + return [lreverse [lsearch -all [lrepeat $count 0] *]] + } else { + incr from + return [lmap v [lrepeat $count 0] {incr from -1}] + } + } + default { + set count [expr {($to - $from + $by) / $by}] + if {$count <= 0} { + #return [list] + return [list $from] ;#review + } + set result [list] + for {set i $from} {$i >= $to} {incr i $by} { + lappend result $i + } + return $result + } } #2) @@ -2468,7 +2539,7 @@ namespace eval punk::lib { #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} { - set expression [tcl::string::map {_ {}} $expression] + set expression [tcl::string::map {_ {}} $expression] ;#review - this is for 8.6 to understand underscored ints if {[tcl::string::is integer -strict $expression]} { return [expr {$expression}] } @@ -2531,22 +2602,35 @@ namespace eval punk::lib { if {$rposn >= 0} { set sepsize 2 set step 1 - } else { + #review - whitespace between ints? + lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + } elseif {[string first . $r] >= 0} { + set stripped [string map {. ""} $r] + if {[tcl::string::length $stripped] != [tcl::string::length $r]-2} { + #if one dot exists - must be exactly 2 dots in total - possibly separated by positive/negative int (not zero) + return 0 + } + #assert - we have exactly 2 dots separated by something. #check for .n. 'stepped' range set fdot [string first . $r] set ldot [string last . $r] set step [string range $r $fdot+1 $ldot-1] #todo - allow basic mathops for step: 2+1 2+-1 etc same as tcl lindex, lseq - if {![string is integer -strict $step]} { - } - } + #1.0.10 should be valid but behave similarly to lseq 1 0 by 0 ie returns nothing - if {$rposn >= 0} { - lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + #1.end.10 or similar shouldn't be valid - but we need to allow other basic index expressions. + if {[string match *end* $step] || [catch {lindex {} $step}]} { + return 0 + } + #if {![string is integer -strict $step] || $step == 0} { + # return 0 + #} + lappend validateindices {*}[string range $r 0 $fdot-1] {*}[string range $r $ldot+1 end] } else { #'range' is just an index set validateindices [list $r] } + foreach v $validateindices { if {$v eq "" || $v eq "end"} {continue} if {[string is integer -strict $v]} {continue} @@ -2558,6 +2642,7 @@ namespace eval punk::lib { return 1 } #review - compare to IMAP4 methods of specifying ranges? + #TODO add tests to test::punk::lib indexset_resolve is a little tricky punk::args::define { @id -id ::punk::lib::indexset_resolve @cmd -name punk::lib::indexset_resolve\ @@ -2568,13 +2653,44 @@ namespace eval punk::lib { e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9 An indexset consists of a comma delimited list of indexes or index-ranges. - Ranges must be specified with .. as the separator, with an empty value at either side of the - separator representing beginning and end of the index range respectively. + Ranges must be specified with a range-indicator such as .. as the separator, with an empty value at + either side of the separator representing beginning and end of the index range respectively. + The range-separator can be of the form .x. where x is an integer or basic expression + (single +/- operation) that indicates the step value to use. This is equivalent to the 'by' value + in the tcl9 lseq command. + + When the start index is lower than the end, the step value defaults to 1. + ie indexset_resolve 0..7 is equivalent to indexset_resolve 0.1.7 + When the start index is higher than the end, the step value defaults to -1. + ie indexset_resolve 7..0 is equivalent to indexset_resolve 0.-1.7 + + If start and end are ommitted, increasing order is assumed if the step isn't specified. + eg + .. represents the range from the base to the end + .-1. would represent end to base with step -1 + + If start is omitted and only the end is supplied: + The default step is 1 indicating ascension and the missing end is equivalent to 'end' + indexset_resolve 5 2.. + -> 2 3 4 + The default end is the base if the step is negative + indexset_resolve 5 2.-1. + -> 2 1 0 + If end is omitted and onlthe start is supplied: + The default step is 1 indicating ascension and the missing start is equivalent to the base. + indexset_resolve 5 ..2 + -> 0 1 2 + The default start is 'end' if the step is negative + indexset_resolve 5 .-1.2 + -> 4 3 2 + + + Like the tcl9 lseq command - a step (by) value of zero produces no results. The indexes are 0-based by default, but the base can be specified. indexset_resolve 7 .. -> 0 1 2 3 4 5 6 - indexset_resolve 7 .. -3 + indexset_resolve -base -3 7 .. -> -3 -2 -1 0 1 2 3 Whitespace is ignored. @@ -2599,10 +2715,9 @@ namespace eval punk::lib { output the first 3 indices, and the last index. end-1..0 output the indexes in reverse order from 2nd last item to first item." - @values -min 2 -max 3 - numitems -type integer - indexset -type indexset -help "comma delimited specification for indices to return" - base -type integer -default 0 -help\ + @leaders -min 0 -max 0 + @opts + -base -type integer -prefix 1 -default 0 -help\ "This is the starting index. It can be positive, negative or zero. This affects the start and end calculations, limiting what indices will be returned. @@ -2613,73 +2728,175 @@ namespace eval punk::lib { For base 1, index 0 is considered to be below the range. ie - indexset_resolve 10 0..3 1 + indexset_resolve -base 1 10 0..3 -> 1 2 3 - indexset_resolve 10 0..3 0 + indexset_resolve -base 0 10 0..3 -> 0 1 2 3 - It does not *convert* integers within the range. + It does not *convert* indexes within the range. - indexset_resolve 10 5 1 + indexset_resolve -base 1 10 5 -> 5 - indexset_resolve 10 5 0 + indexset_resolve -base 0 10 5 -> 5 - ie if you ask for a 1 based indexset the integers that are within the - range will come out the same, so the result needs to be treated as a - 1-based set of indices when performing further operations. + ie if you ask for a 1-based resolution of an indexset the integers that are within + the range will come out the same, so the result needs to be treated as a 1-based + set of indices when performing further operations. " + @values -min 2 -max 3 + numitems -type integer + indexset -type indexset -help "comma delimited specification for indices to return" } - proc indexset_resolve {numitems indexset {base 0}} { + + #limit punk::args parsing to unhappy paths where possible + proc indexset_resolve {args} { + # -------------------------------------------------- + # Manual parsing of happy path args instead of using punk::args::parse $args withid ::punk::lib::indexset_resolve + # This is because indexset_resolve is *somewhat* low level, has only a few args, and we don't want any overhead. + # for the unhappy path - the punk::args::parse is fine to generate the usage/error information. + # -------------------------------------------------- + if {[llength $args] < 2} { + punk::args::resolve $args withid ::punk::lib::indexset_resolve + } + set indexset [lindex $args end] + set numitems [lindex $args end-1] if {![string is integer -strict $numitems] || ![is_indexset $indexset]} { #use parser on unhappy path only set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] } + #assert we have 2 or more args + set base 0 ;#default + if {[llength $args] > 2} { + #if more than just numitems and indexset - we expect only -base ie 4 args in total + if {[llength $args] != 4} { + set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] + } + set optname [lindex $args 0] + set optval [lindex $args 1] + set fulloptname [tcl::prefix::match -error "" -base $optname] + if {$fulloptname ne "-base" || ![string is integer -strict $optval]} { + set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] + } + set base $optval + } + # -------------------------------------------------- + + set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace set index_list [list] ;#list of actual indexes within the range set iparts [split $indexset ,] set based_max [expr {$numitems -1 + $base}] + #we already did is_indexset check above, so we can make assumptions about well-formedness of each part foreach ipart $iparts { set ipart [string trim $ipart] - set rposn [string first .. $ipart] + #we need to cater for n..m as well as n.s.m where s is 'step' + set rposn [string first . $ipart] if {$rposn>=0} { - #range - lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb - set rawa [string trim $rawa] - set rawb [string trim $rawb] - if {$rawa eq ""} {set rawa $base} - set a [punk::lib::lindex_resolve $numitems $rawa $base] - if {$a == -Inf} { - #(was -3) - #undershot - leave negative - } elseif {$a == Inf} { - #overshot - set a [expr {$based_max + 1}] ;#put it outside the range on the upper side + #if we found one dot - there must be exactly 2 dots in the ipart, separated by nothing, or a basic integer-expression + set rposn2 [string last . $ipart] + if {$rposn2 == $rposn+1} { + #.. + set step "default" ;#could be 1 or -1 + } else { + set step [tcl::string::range $ipart $rposn+1 $rposn2-1] } - #review - a may be -Inf + lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn2+1] rawa _ rawb - if {$rawb eq ""} { - if {$a > $based_max} { - set rawb $a ;#make sure .. doesn't return last item - should return nothing + set rawa [string trim $rawa] + set rawb [string trim $rawb] + if {$rawa eq "" && $rawb eq ""} { + if {$step eq "default"} { + set step 1 ;#default ascending when no start and no end + } + if {$step < 0} { + set rawa end + set rawb $base } else { + set rawa $base set rawb end } - } - set b [punk::lib::lindex_resolve $numitems $rawb $base] - if {$b == -Inf} { - #undershot - leave negative - } elseif {$b == Inf} { - #set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side - set b [expr {$based_max + 1}] ;#overshot - put it outside the range on the upper side + #if neither start nor end specified - we won't get out of range results from lindex_resolve + set a [punk::lib::lindex_resolve $numitems $rawa $base] + set b [punk::lib::lindex_resolve $numitems $rawb $base] + } else { + if {$rawa eq ""} { + if {$step eq "default"} { + #when start not specified, but end is - default direction always ascending + #(even if end is base or below range) + set step 1 + } + if {$step < 0} { + set rawa end + } else { + set rawa $base + } + } + set a [punk::lib::lindex_resolve $numitems $rawa $base] + if {$a == -Inf} { + #undershot - leave negative + } elseif {$a == Inf} { + #overshot + set a [expr {$based_max + 1}] ;#put it outside the range on the upper side + } + #review - a may be -Inf + + if {$rawb eq ""} { + if {$step eq "default"} { + set step 1 + } + if {$step < 0} { + if {$a < $base} { + #make sure both + #mathfunc::isinf is tcl9+ + if {[catch { + if {[::tcl::mathfunc::isinf $a]} { + set a [expr {$base -1}] + } + }]} { + if {[string match -nocase *inf* $a]} { + set a [expr {$base -1}] + } + } + set rawb $a + } else { + set rawb $base + } + } else { + if {$a > $based_max} { + set rawb $a ;#make sure .. doesn't return last item - should return nothing + } else { + set rawb end + } + } + } + set b [punk::lib::lindex_resolve $numitems $rawb $base] + if {$b == -Inf} { + #undershot - leave negative + } elseif {$b == Inf} { + #set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side + set b [expr {$based_max + 1}] ;#overshot - put it outside the range on the upper side + } } #JJJ #e.g make sure .. doesn't return last item - should return nothing as both are above the range. if {$a >= $base && $a <= $based_max && $b >=$base && $b <= $based_max} { - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + #assert a & b are integers within the range + if {$step eq "default"} { + #unspecified step - base direction on order of a & b + if {$a <= $b} { + set step 1 + } else { + set step -1 + } + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } else { if {$a >= $base && $a <= $based_max} { #only a is in the range @@ -2688,27 +2905,57 @@ namespace eval punk::lib { } else { set b $based_max } - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + if {$step eq "default"} { + if {$a <= $b} { + set step 1 + } else { + set step -1 + } + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } elseif {$b >=$base && $b <= $based_max} { #only b is in the range - if {$a < $base} { - set a $base + if {$step eq "default"} { + if {$a <= $b} { + set step 1 + } else { + set step -1 + } + } + if {$step < 0} { + if {$a < $base} { + #negative step from below - doesn't matter if b is in range - recast both to an int below $base + #(a may be -Inf) + set a [expr {$base -1}] + set b $a + set step 0 ;#we should return nothing + } } else { - set a $based_max + if {$a < $base} { + set a $base + } else { + set a $based_max + } } - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } else { #both outside the range if {$a < $base && $b > $base} { #spans the range in forward order set a $base set b $based_max - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + if {$step eq "default"} { + set step 1 + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } elseif {$a > $base && $b < $base} { #spans the range in reverse order set a $based_max set b $base - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + if {$step eq "default"} { + set step -1 + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } #both outside of range on same side } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm index fea6b146..d7eaf639 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -62,7 +62,7 @@ package require Tcl 8.6- -tcl::namespace::eval punk::libunknown { +tcl::namespace::eval ::punk::libunknown { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -1576,7 +1576,7 @@ tcl::namespace::eval punk::libunknown { } # == === === === === === === === === === === === === === === -namespace eval punk::libunknown { +namespace eval ::punk::libunknown { #for 8.6 compat if {"::ledit" ni [info commands ::ledit]} { #maint: taken from punk::lib @@ -1702,7 +1702,7 @@ namespace eval punk::libunknown { } } -tcl::namespace::eval punk::libunknown::lib { +tcl::namespace::eval ::punk::libunknown::lib { #A version of textutil::string::longestCommonPrefixList #(also as ::punk::lib::longestCommonPrefixList) @@ -1788,7 +1788,7 @@ namespace eval ::punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready -package provide punk::libunknown [tcl::namespace::eval punk::libunknown { +package provide punk::libunknown [tcl::namespace::eval ::punk::libunknown { variable pkg punk::libunknown variable version set version 0.1 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index 30941f83..96f506b5 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -52,7 +52,10 @@ if {[package provide punk::libunknown] eq ""} { if {$libunknown ne ""} { uplevel 1 [list source $libunknown] if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { - puts "error initialising punk::libunknown\n$errM" + puts stderr "error initialising punk::libunknown during punk::repl package load of script [info script]" + puts stderr "sourcing from: $libunknown" + puts stderr "tcl::tm::list: [tcl::tm::list]" + puts stderr $errM } } }} @@ -3593,7 +3596,9 @@ namespace eval repl { if {$libunknown ne ""} { uplevel 1 [list ::source $libunknown] if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { - puts "error initialising punk::libunknown\n$errM" + puts stderr "error initialising punk::libunknown\n from: '$libunknown'" + puts stderr "tcl::tm::list: [tcl::tm::list]" + puts stderr "error: $errM" } } }} diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm index 15c036ca..558f6bde 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm @@ -4897,7 +4897,6 @@ tcl::namespace::eval punk::args { lappend PUNKARGS [list { - @dynamic @id -id ::punk::args::usage @cmd -name punk::args::usage -help\ "Return usage information for a command identified by an id. diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm index 004c790b..5623e7c9 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm @@ -8316,7 +8316,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { 4. If the end of the input string is reached before any conversions have been performed and no variables are given, an empty string is returned. } - @values -min 1 -max 2 + @values -min 2 -max 3 string -type string format -type string varName -type string -optional 1 -multiple 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 39eeccd2..3bbc65cf 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 @@ -515,8 +515,18 @@ namespace eval punk::console { } } - exec {*}$sttycmd raw -echo <@$channel - tsv::set console is_raw 1 + #REVIEW + switch $channel { + stdin { + exec {*}$sttycmd -icanon -echo -isig + } + default { + exec {*}$sttycmd raw -echo <@$channel + } + } + catch { + tsv::set console is_raw 1 + } return [dict create previous [set previous_stty_state_$channel]] } proc disableRaw {{channel stdin}} { @@ -529,8 +539,18 @@ namespace eval punk::console { tsv::set console is_raw 0 return restored } - exec {*}$sttycmd -raw echo <@$channel - tsv::set console is_raw 0 + #REVIEW + switch $channel { + stdin { + exec {*}$sttycmd icanon echo isig + } + default { + exec {*}$sttycmd -raw echo <@$channel + } + } + catch { + tsv::set console is_raw 0 + } return done } } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.1.tm new file mode 100644 index 00000000..82672d11 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.1.tm @@ -0,0 +1,4444 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# IMAP4 protocol pure Tcl implementation. +# +# COPYRIGHT AND PERMISSION NOTICE +# +# Copyright (C) 2025 Julian Noble +# Copyright (C) 2004 Salvatore Sanfilippo +# Copyright (C) 2013 Nicola Hall +# Copyright (C) 2013 Magnatune +# +# All rights reserved. +# +# Permission is hereby granted, free of charge, to any person obtaining a +# copy of this software and associated documentation files (the +# "Software"), to deal in the Software without restriction, including +# without limitation the rights to use, copy, modify, merge, publish, +# distribute, and/or sell copies of the Software, and to permit persons +# to whom the Software is furnished to do so, provided that the above +# copyright notice(s) and this permission notice appear in all copies of +# the Software and that both the above copyright notice(s) and this +# permission notice appear in supporting documentation. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT +# OF THIRD PARTY RIGHTS. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR +# HOLDERS INCLUDED IN THIS NOTICE BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL +# INDIRECT OR CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING +# FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, +# NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION +# WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +# +# Except as contained in this notice, the name of a copyright holder +# shall not be used in advertising or otherwise to promote the sale, use +# or other dealings in this Software without prior written authorization +# of the copyright holder. + +# TODO +# - Idle mode +# - Async mode +# - More Authentications (currently AUTH_LOGIN AUTH_PLAIN) +# - handle [OVERQUOTA] response +# - Literals on file mode +# - fix OR in search, and implement time-related searches +# All the rest... see the RFCs + +#JN TODO +#rfc4551 CONDSTORE - (MODSEQ,NOMODSEQ,HIGHESTMODSEQ) +#rfc2117 IDLE + +# History +# 20100623: G. Reithofer, creating tcl package 0.1, adding some todos +# option -inline for ::imap4::fetch, in order to return data as a Tcl list +# isableto without arguments returns the capability list +# implementation of LIST command +# 20100709: Adding suppport for SSL connections, namespace variable +# use_ssl must be set to 1 and package TLS must be loaded +# 20100716: Bug in parsing special leading FLAGS characters in FETCH +# command repaired, documentation cleanup. +# 20121221: Added basic scope, expunge and logout function +# 20130212: Added basic copy function +# 20130212: Missing chan parameter added to all imaptotcl* procs -ger +# 20250223: J. Noble - fork for punk::imap4 +# Argument parsing and documentation with punk::args +# Change from use_ssl and debug vars in base namespace to options -security and -debug on OPEN command +# This enables support of simultaneous Imap connections with different values of tls/debug +# Default to either TLS or STARTSSL unless user specifically requests -security none +# API reorg into namespaces, and capitalisation of commands that use the IMAP protocol vs lowercase for operations on already +# retrieved state. +# showlog command to see cli/svr conversation - todo! - disable by default and limit storage. +# Addition of AUTH_PLAIN SASL authentication mechanism +# change isableto -> has_capability (to better reflect capabilities such as LOGINDISABLED) +# 202503 J. Noble - API changes, add more argument parsing/documentation +# Change IMAP API commands that take msgid or range to accept IMAP protocol style sequence-sets +# composed of seq-ranges. +# ie - no longer accept tcllib IMAP4 style range consisting of incomplete colon based ranges such as : :x x: +# Instead we accept the full comma delimited sequence sets and require use of the special * operator in ranges +# e.g 1:* 3,4,10:* etc +# The equivalent of tcllib IMAP's : would be 1:* +# Added GETACL,SETACL,MYRIGHTS,LISTRIGHTS commands. +# Added initial RETURN handling for SEARCH (not yet handling ESEARCH responses) +# Changed OPEN to CONNECT +# (slightly better clarity for API because the IMAP CLOSE command is not the opposite of OPEN) + +# +# @@ Meta Begin +# Application punk::imap4 0.9.1 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::imap4 0 0.9.1] +#[copyright "2025"] +#[titledesc {IMAP4 client}] [comment {-- Name section and table of contents description --}] +#[moddesc {IMAP4 client}] [comment {-- Description at end of page heading --}] +#[require punk::imap4] +#[keywords module mail imap imap4 client mailclient] +#[description] +#[para] An implementation of IMAP4 (rev1+?) client protocol + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::imap4 +#[subsection Concepts] +#[para] - + +tcl::namespace::eval punk::imap4 { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id "(package)punk::imap4" + @package -name "punk::imap4"\ + -title "IMAP4 client library"\ + -description "An implementation of IMAP4 (rev1+?) client protocol."\ + -copyright "2025" + }] + + if {[info exists ::argv0] && [info script] eq $::argv0} { + #assert? - if argv0 exists and is same as [info script] - we're not in a safe interp + #when running a tm module as an app - we should calculate the corresponding tm path + #based on info script and the namespace of the package being provided here + #and add that to the tm list if not already present. + #(auto-cater for any colocated dependencies) + set scr [file normalize [info script]] + set ns [namespace current] + #puts "scr:--$scr--" + #puts "ns: --$ns--" + set scriptdir [file dirname $scr] + set mapped [string map {:: \u0FFF} [string trimleft $ns :]] + set nsparts [split $mapped \u0FFF] + set nsprefix [lrange $nsparts 0 end-1] + if {![llength $nsprefix]} { + #current script dir is a tm root + if {$scriptdir ni [tcl::tm::list]} { + tcl::tm::add $scriptdir + } + } else { + set pathparts [file split $scriptdir] + set count_match 0 + set i 0 + foreach ns_seg [lreverse $nsprefix] path_seg [lreverse $pathparts] { + if {[string tolower $ns_seg] eq [string tolower $path_seg]} { + incr count_match + } + incr i + if {$i >= [llength $nsprefix]} {break} + } + if {$count_match == [llength $nsprefix]} { + set tmparts [lrange $pathparts 0 end-$count_match] + set tmpath [file join {*}$tmparts] + #puts "--adding tmpath $tmpath --" + if {$tmpath ni [tcl::tm::list]} { + tcl::tm::add $tmpath + } + } + } + #app at tail of script + } +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::imap4 +#[list_begin itemized] + +package require Tcl 8.6.2- +package require punk::args +package require punk::lib +#*** !doctools +#[item] [package {Tcl 8.6.2-}] +#[item] [package {punk::args}] +#[item] [package {punk::lib}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +tcl::namespace::eval punk::imap4::system { + variable conlog + set conlog [dict create] ;#client/server chat log. keyed on $chan. Members {side c|s type line|chunk data "..."} + + proc add_conlog {chan side request_tag type datalist} { + if {$side ni {c s}} { + error "add_conlog side must be c or s" + } + if {$type ni {line literal chunk}} { + error "add_conlog type must be line literal or chunk" + } + variable conlog + set records [list] + foreach d $datalist { + dict lappend conlog $chan [dict create side $side request $request_tag type $type data $d] + } + return [llength $datalist] + } + proc get_conlog {chan {tag *}} { + variable conlog + if {$tag eq "*"} { + return [dict get $conlog $chan] + } else { + #retrieve + set loglist [dict get $conlog $chan] + #review - the relevant loglines should all be tagged with the 'request' key even if response line was a * + return [lsearch -all -inline -index 3 $loglist $tag] + #set result [list] + #set first [lsearch -index 3 $loglist $tag] + #if {$first > -1} { + # set last [lsearch -index 3 -start $first+1 $loglist $tag] + # if {$last > -1} { + # set result [lrange $loglist $first $last] + # } else { + # set result [lrange $loglist $first end] ;#review + # } + #} + #return $result + } + } +} + +tcl::namespace::eval punk::imap4::stringprep { + #https://core.tcl-lang.org/tcllib/doc/tcllib-1-18/embedded/www/tcllib/files/modules/stringprep/stringprep.html#3 + + #RFC3454 - table definitions + + #IMAP stringprep Profiles for Usernames RFC4314 RFC5738 + #IMAP stringprep Profiles for Passwords RFC5738 + + #RFC4013 SASLprep: Stringprep Profile for User Names and Passwords + #Prohibited Output + # - Non-ASCII space characters [StringPrep, C.1.2] + # - ASCII control characters [StringPrep, C.2.1] + # - Non-ASCII control characters [StringPrep, C.2.2] + # - Private Use characters [StringPrep, C.3] + # - Non-character code points [StringPrep, C.4] + # - Surrogate code points [StringPrep, C.5] + # - Inappropriate for plain text characters [StringPrep, C.6] + # - Inappropriate for canonical representation characters + # [StringPrep, C.7] + # - Change display properties or deprecated characters + # [StringPrep, C.8] + # - Tagging characters [StringPrep, C.9] + set prohibited_sets {A.1 C.1.2 C.2.1 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} + + #This profile specifies: + # - non-ASCII space characters [StringPrep, C.1.2] that can be + # mapped to SPACE (U+0020), and + # - the "commonly mapped to nothing" characters [StringPrep, B.1] + # that can be mapped to nothing. + + #Unassigned Code points - [STRINGPREP, A.1] + + package require stringprep + #Mapping C.1.2 ?? + #we only have it in -prohibited - but it seems to be mapped to space, which is what we want - but why? + ::stringprep::register saslprep -mapping {B.1} -prohibited $prohibited_sets -normalization KC -prohibitedBidi 1 + + proc normal_userpass {input} { + #set input [map_to_space $input] ;#C.1.2 non-ascii spaces mapped to space + set normalised [::stringprep::stringprep saslprep $input] + } + + #probably unneeded - see command above re mapping C.1.2 + proc map_to_space {input} { + #C.1.2 Non-ASCII space characters + #----- Start Table C.1.2 ----- + #00A0; NO-BREAK SPACE + #1680; OGHAM SPACE MARK + #2000; EN QUAD + #2001; EM QUAD + #2002; EN SPACE + #2003; EM SPACE + #2004; THREE-PER-EM SPACE + #2005; FOUR-PER-EM SPACE + #2006; SIX-PER-EM SPACE + #2007; FIGURE SPACE + #2008; PUNCTUATION SPACE + #2009; THIN SPACE + #200A; HAIR SPACE + #200B; ZERO WIDTH SPACE + #202F; NARROW NO-BREAK SPACE + #205F; MEDIUM MATHEMATICAL SPACE + #3000; IDEOGRAPHIC SPACE + #----- End Table C.1.2 ----- + set map [list \u00A0 " " \u1680 " " \u2000 " " \u2001 " " \u2002 " " \u2003 " " \u2004 " " \u2005 " " \u2006 " " \u2007 " "\ + \u2007 " " \u2008 " " \u2009 " " \u200A " " \u200b " " \u202F " " \u205F " " \u3000 " "\ + ] + return [string map $map $input] + } +} + +tcl::namespace::eval punk::imap4::proto { + variable PUNKARGS + variable coninfo + namespace export {[a-z]*} + + proc is_imap_number {n} { + return [expr {[string is integer -strict $n] && $n >= 0 && $n <= 4294967296}] + } + proc is_imap_number64 {n} { + return [expr {[string is integer -strict $n] && $n >= 0 && $n <= 9223372036854775807}] + } + proc is_imap_nznumber {n} { + return [expr {[string is integer -strict $n] && $n > 0 && $n <= 4294967296}] + } + proc is_imap_nznumber64 {n} { + return [expr {[string is integer -strict $n] && $n > 0 && $n <= 9223372036854775807}] + } + + #JMN 2025 - rename to pop0 to make clear distinction between this and tcl9 builtin lpop + # Pop an element from the list inside the named variable and return it. + # If a list is empty, raise an error. The error is specific for the + # search command since it's the only one calling this function. + if {[info commands ::lpop] ne ""} { + proc pop0 {listvar} { + upvar 1 $listvar l + if {![llength $l]} { + error "Bad syntax for search expression (missing argument)" + } + lpop l 0 + } + } else { + proc pop0 {listvar} { + upvar 1 $listvar l + + if {![llength $l]} { + error "Bad syntax for search expression (missing argument)" + } + + set res [lindex $l 0] + set l [lrange $l 1 end] + return $res + } + } + + ### connection/protocol state + array set info {} ;# general connection state info. + set coninfo [dict create] ;# connection properties info. keyed on $chan. Members {hostname port debug 0|1 security None|TLS/SSL|STARTSSL} + + # Initialize the info array for a new connection. + proc initinfo {chan} { + variable info + set info($chan,curtag) 0 + set info($chan,state) NOAUTH + set info($chan,folders) {} + set info($chan,capability) {} + set info($chan,raise_on_NO) 0 + set info($chan,raise_on_BAD) 1 + set info($chan,idle) {} + set info($chan,lastcode) {} + set info($chan,lastline) {} + set info($chan,lastrequest) {} + + #set idle as timestamp of when started? + } + + lappend PUNKARGS [list { + @id -id ::punk::imap4::proto::tag + @cmd -name punk::imap4::proto::tag -help\ + "Return the next tag to use in IMAP requests." + @leaders -min 0 -max 0 + @values -min 1 -max 1 + chan -optional 0 -help\ + "existing channel for an open IMAP connection" + }] + proc tag {chan} { + variable info + incr info($chan,curtag) + } + + # ------------------------------------------------ + # used primarily by client api namespace ::punk::imap4 with simple wrappers + # proto functions can access info directly + # ------------------------------------------------ + # Returns the last error code received. + proc lastcode {chan} { + variable info + return $info($chan,lastcode) + } + # Returns the last line received from the server. + proc lastline {chan} { + variable info + return $info($chan,lastline) + } + proc lastrequest {chan} { + variable info + return $info($chan,lastrequest) + } + proc lastrequesttag {chan} { + variable info + set lastrequest $info($chan,lastrequest) + #we aren't assuming all request formats are valid Tcl lists + return [punk::imap4::lib::firstword $lastrequest] + } + + #experimental + proc resync_tag {chan} { + set last_request_tag [lastrequesttag $chan] + set last_line [lastline $chan] + #word0 + set last_response_tag [punk::imap4::lib::firstword $last_line] + puts stderr "last request tag: $last_request_tag" + puts stderr "last response tag: $last_response_tag" + if {$last_response_tag < $last_request_tag} { + set diff [expr {$last_request_tag - $last_response_tag}] + puts stderr "Reading $diff responses to catch up.." + set servertag $last_response_tag + for {set i 0} {$i < $diff} {incr i} { + #JMN + set is_err [catch {getresponse $chan [incr servertag]} getresponse_result] + if {!$is_err} { + if {$getresponse_result == 0} { + puts stderr "READ read number: $i result: $getresponse_result" + } else { + puts stderr "READPROBLEM read number: $i result: $getresponse_result" + } + } else { + puts stderr "READERROR read number: $i" + puts stderr " error: $getresponse_result" + } + } + #todo retest? + puts stderr "Done - view log using 'showlog $chan'" + } elseif {$last_response_tag > $last_request_tag} { + set synctag [expr {$last_response_tag + 1}] + puts stderr "Updating client curtag to $synctag" + upvar ::punk::imap4::proto::info info + set info($chan,curtag) $synctag + puts stderr "calling NOOP" + punk::imap4::NOOP $chan + #todo - retest? + puts stderr "Done" + } else { + puts stderr "resync_tag - OK No difference detected" + } + } + + # Get the current state + proc state {chan} { + variable info + return $info($chan,state) + } + # Test for capability. Use the capability command + # to ask the server if not already done by the user. + + lappend PUNKARGS [list { + @id -id ::punk::imap4::proto::has_capability + @cmd -name punk::imap4::proto::has_capability -help\ + "Return a list of the server capabilities last received, + or a boolean indicating if a particular capability was + present." + @leaders -min 1 -max 1 + chan -optional 0 -help\ + "existing channel for an open IMAP connection" + @values -min 0 -max 1 + capability -type string -default "" -help\ + "The name of a capability to look for + in the cached response." + }] + proc has_capability {chan {capability ""}} { + variable info + + #REVIEW - do we want this command to re-hit the server? + #Under what circumstances is there nothing cached for the channel? + #set resultcode 0 + #if {![llength $info($chan,capability)]} { + # set resultcode [punk::imap4::CAPABILITY $chan] ;#review should unwrap - proto shouldn't depend on cli API namespace ? + #} + + if {$capability eq ""} { + #if {$resultcode != 0} { + # # We return empty string on error + # return "" + #} + return $info($chan,capability) + } + + set capability [string toupper $capability] + expr {[lsearch -exact $info($chan,capability) $capability] != -1} + } + + #requires the listed caps are in the latest capabilities set received.. + proc requirecaps {chan requiredcaps} { + variable info + #if {![llength $info($chan,capability)]} { + # punk::imap4::CAPABILITY $chan ;#review should unwrap - proto shouldn't depend on cli API namespace ? + #} + if {![llength $requiredcaps]} { + return + } + set requiredcaps [string toupper $requiredcaps] + set missing [list] + foreach c $requiredcaps { + if {[lsearch $info($chan,capability) $c] == -1} { + lappend missing $c + } + } + if {[llength $missing]} { + if {[llength $missing] == 1} { + set cap [lindex $missing 0] + error "IMAP SERVER has NOT advertised the capability '$cap' in the current protocol state." + } else { + error "IMAP SERVER has NOT advertised the capabilities '$missing' in the current protocol state." + } + } + } + # ------------------------------------------------ + + # Assert that the channel is one of the specified states + # by the 'states' list. + # otherwise raise an error. + proc requirestate {chan states} { + variable info + if {"*" in $states} {return} + if {[lsearch $states $info($chan,state)] == -1} { + error "IMAP channel not in one of the following states: '$states' (current state is '$info($chan,state)')" + } + } + + # This a general implementation for a simple implementation + # of an IMAP command that just requires to call ::imap4::request + # and ::imap4::getresponse. + lappend PUNKARGS [list { + @id -id ::punk::imap4::proto::simplecmd + @cmd -name punk::imap4::proto::simplecmd -help\ + "This is a general implementation for a simple + implementation of an IMAP command that is + composed of a a ::punk::imap4::request followed + by a punk::imap4::response" + + @leaders -min 1 -max 1 + chan -optional 0 -help\ + "existing channel for an open IMAP connection" + @opts + -validstates -default * -help\ + "A list of valid states from which this + command can be called" + @values -min 1 -max -1 + command -type string + arg -multiple 1 -optional 1 -help\ + {Each argument for the command must be + supplied in a way that preserved the form + expected by an IMAP server. + For example, if an argument has spaces it + may need to be in double quotes and so need + to be explicitly specified with quotes and a + protecting set of braces. + e.g + simplecmd EXAMINE {"mailbox name with spaces"} + If Tcl variable substitution is required, escapes + within a quoted string could be used, or string map. + e.g + simplecmd $ch SETMETADATA $b "($ann \"$val\")" + } + }] + proc simplecmd {args} { + set argd [punk::args::parse $args withid ::punk::imap4::proto::simplecmd] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set validstates [dict get $opts -validstates] + set command [dict get $values command] + set arglist [list] + if {[dict exists $received arg]} { + set arglist [dict get $values arg] + } + + requirestate $chan $validstates + + set req "$command" + foreach arg $arglist { + append req " $arg" + } + + #let 'request' store the command + set clitag [request $chan $req] + if {[getresponse $chan $clitag] != 0} { + return 1 + } + + return 0 + } + # Write a request. - this risks getting our local state out of sync + proc request {chan request} { + variable info + variable coninfo + #variable pipeline ;#todo?? + set clitag [tag $chan] + set t "$clitag [string trim $request]" + if {[dict get $coninfo $chan debug]} { + puts "([dict get $coninfo $chan hostname])C: $t" + } + set info($chan,lastrequest) $t + puts -nonewline $chan "$t\r\n" + flush $chan + ::punk::imap4::system::add_conlog $chan c $clitag line [list $t] + return $clitag + } + # Process IMAP responses. If the IMAP channel is not + # configured to raise errors on IMAP errors, returns 0 + # on OK response, otherwise 1 is returned. + proc getresponse {chan {clitag *}} { + variable info + + #todo pipeline - not lastrequest + #this is just an IDLE initial test + set lastcmd [punk::imap4::lib::secondword [lastrequest $chan]] + + switch -- $lastcmd { + IDLE { + while {[set responsetag [processline $chan $clitag]] eq {*}} {} + } + default { + # Process lines until the tagged one. + while {[set responsetag [processline $chan $clitag]] eq {*} || $responsetag eq {+}} {} + } + } + + + switch -- [lastcode $chan] { + OK { + # + return 0 + } + NO { + if {$info($chan,raise_on_NO)} { + error "IMAP error: [lastline $chan]" + } + return 1 + } + BAD { + if {$info($chan,raise_on_BAD)} { + protoerror $chan "IMAP error: [lastline $chan]" + } + return 1 + } + + { + if {$lastcmd eq "IDLE"} { + #todo - verify '+ idling' case? + set info($chan,idle) [clock seconds] + } else { + #assert - can't happen + } + return 1 + } + default { + protoerror $chan "IMAP protocol error. Unknown response code '[lastcode $chan]'" + } + } + } + + + # Process an IMAP response 'logical' line. + # This function trades simplicity in IMAP commands + # implementation with monolithic handling of responses. + # However note that the IMAP server can reply to a command + # with many different untagged responses, so to have the reply + # processing centralized makes this simple to handle. + # + # Returns the line's tag. + proc processline {chan request_tag} { + variable info ;#state info + variable coninfo ;#general server/connection info vs state info + #upvar ::punk::imap4::mboxinfo mboxinfo + upvar ::punk::imap4::folderinfo folderinfo + + #consider the following FETCH response lines with literals + #This entire sequence is what we process as a 'line' here + #* 53 FETCH (RFC822.HEADER {4215}\r\n + #<4215 bytes> + #BODY[] {5150}\r\n + #<5150 bytes> + #)\r\n + + chan conf $chan -blocking 1 + + set literals {} + set line "" + while {1} { + # Read a physical line - which may be only part of the logical line if there is a 'literal' specifier + if {[gets $chan buf] == -1} { + error "([dict get $coninfo $chan hostname])IMAP unexpected EOF from server." + } + # Remove the trailing CR at the end of the buf, if any. + if {[string index $buf end] eq "\r"} { + set buf [string range $buf 0 end-1] + } + ::punk::imap4::system::add_conlog $chan s $request_tag line [list $buf] ;# + if {[dict get $coninfo $chan debug]} { + puts "([dict get $coninfo $chan hostname])S: $buf" + } + append line $buf + + # Check if there is a literal specified. + # It will always occur at the end of a line - followed by the data to read + if {[regexp {{([0-9]+)}\s*$} $buf => length]} { + # puts "Reading $length bytes of literal..." + set chunk [read $chan $length] + lappend literals $chunk + #add_conlog $chan $side $type + ::punk::imap4::system::add_conlog $chan s $request_tag literal [list [dict create length $length lines [llength [split $chunk \n]]]] + if {[dict get $coninfo $chan debug]} { + puts "([dict get $coninfo $chan hostname])s: <$length bytes>" + ::punk::imap4::system::add_conlog $chan s $request_tag chunk [list [list length $length chunk $chunk]] + } + } else { + #We are at the end of a single line, + #or a sequence of 1 or more physical lines which had trailing literal specifiers {nnn} followed by data we have read. + break + } + } + + set info($chan,lastline) $line + + + # Extract the tag. + set idx [string first { } $line] + if {$idx <= 0} { + protoerror $chan "IMAP: malformed response '$line'" + } + + set tag [string range $line 0 $idx-1] + set line [string range $line $idx+1 end] + # If it's just a command continuation response, return. REVIEW + #except for IDLE (others?) + if {$tag eq {+}} {return +} + + # Extract the error code, if it's a tagged line + if {$tag ne "*"} { + set idx [string first { } $line] + if {$idx <= 0} { + protoerror $chan "IMAP: malformed response '$line'" + } + set code [string range $line 0 $idx-1] + set line [string trim [string range $line $idx+1 end]] + set info($chan,lastcode) $code + } + + set dirty 0 ;#review - naming as 'dirty' seems odd + #This seems to just indicate we've already matched a result as the implementation + #splits the scanning into two switch statements. + + # Extract information from the line + switch -glob -- $line { + {*\[READ-ONLY\]*} {::punk::imap4::_set_mboxinfo $chan perm READ-ONLY; incr dirty} + {*\[READ-WRITE\]*} {::punk::imap4::_set_mboxinfo $chan perm READ-WRITE; incr dirty} + {*\[TRYCREATE\]*} {::punk::imap4::_set_mboxinfo $chan perm TRYCREATE; incr dirty} + {LIST *(*)*} { + # regexp not secure enough ... delimiters must be PLAIN SPACES (see RFC) + # set res [regexp {LIST (\(.*\))(!?\s)[ ](.*)$} $line => flags delim fname] + # p1| p2| p3| + # LIST (\Noselect) "/" ~/Mail/foo + set p1 [string first "(" $line] + set p2 [string first ")" $line $p1+1] + set p3 [string first " " $line $p2+2] + if {$p1<0||$p2<0||$p3<0} { + protoerror $chan "IMAP: Not a valid RFC822 LIST format in '$line'" + } + set flags [string range $line $p1+1 $p2-1] + set delim [string range $line $p2+2 $p3-1] + set fname [string range $line $p3+1 end] + if {$fname eq ""} { + set folderinfo($chan,delim) [string trim $delim "\""] + } else { + set fflag {} + foreach f [split $flags] { + lappend fflag $f + } + lappend folderinfo($chan,names) $fname + lappend folderinfo($chan,flags) [list $fname $fflag] + if {$delim ne "NIL"} { + set folderinfo($chan,delim) [string trim $delim "\""] + } + } + incr dirty + } + {FLAGS *(*)*} { + regexp {.*\((.*)\).*} $line => flags + #set mboxinfo($chan,flags) $flags + ::punk::imap4::_set_mboxinfo $chan flags $flags + incr dirty + } + {*\[PERMANENTFLAGS *(*)*\]*} { + regexp {.*\[PERMANENTFLAGS \((.*)\).*\].*} $line => flags + #set mboxinfo($chan,permflags) $flags + ::punk::imap4::_set_mboxinfo $chan permflags $flags + incr dirty + } + {*\[CAPABILITY *\]*} { + #can appear in tagged responses to LOGIN or AUTHENTICATE + #e.g + #cli> 1 LOGIN user pass + #svr> 1 OK [CAPABILITY IMAP4rev1 ... ] User logged in SESSIONID= + regexp {.*\[CAPABILITY\s+(.*)\]\s*(.*)$} $line => capstring tailstring + #consider the capability: RIGHTS=kxten + #Probably inappropriate to convert to uppercase, standard rights are defined as lowercase. + #(no uppercase rights currently allowed - but perhaps that may change?) + # Unknown if there are other capabilities with lowercase values. + #set info($chan,capability) [split [string toupper $capstring]] + set info($chan,capability) [split $capstring] + incr dirty + if {$tailstring ne ""} { + if {[dict get $coninfo $chan debug]} { + puts "([dict get $coninfo $chan hostname])*** WARNING: unprocessed TAIL after CAPABILITY '$line'" + } + } + } + } + + #If tag eq * - we could still have an OK not stripped from line above + #e.g initial connection response + #REVIEW - + if {!$dirty && $tag eq {*}} { + switch -regexp -nocase -- $line { + {^[0-9]+\s+EXISTS} { + #regexp {^([0-9]+)\s+EXISTS} $line => mboxinfo($chan,exists) + regexp {^([0-9]+)\s+EXISTS} $line => val + punk::imap4::_set_mboxinfo $chan exists $val + incr dirty + } + {^[0-9]+\s+RECENT} { + #DEPRECATED response for imaprev2 - should ignore? + #regexp {^([0-9]+)\s+RECENT} $line => mboxinfo($chan,recent) + regexp {^([0-9]+)\s+RECENT} $line => val + punk::imap4::_set_mboxinfo $chan recent $val + incr dirty + } + {.*?\[UIDVALIDITY\s+[0-9]+?\]} { + #regexp {.*?\[UIDVALIDITY\s+([0-9]+?)\]} $line => \ + # mboxinfo($chan,uidval) + regexp {.*?\[UIDVALIDITY\s+([0-9]+?)\]} $line => val + punk::imap4::_set_mboxinfo $chan uidval $val + incr dirty + } + {.*?\[UNSEEN\s+[0-9]+?\]} { + #regexp {.*?\[UNSEEN\s+([0-9]+?)\]} $line => \ + # mboxinfo($chan,unseen) + regexp {.*?\[UNSEEN\s+([0-9]+?)\]} $line => val + punk::imap4::_set_mboxinfo $chan unseen $val + incr dirty + } + {.*?\[UIDNEXT\s+[0-9]+?\]} { + #regexp {.*?\[UIDNEXT\s+([0-9]+?)\]} $line => \ + # mboxinfo($chan,uidnext) + regexp {.*?\[UIDNEXT\s+([0-9]+?)\]} $line => val + punk::imap4::_set_mboxinfo $chan uidnext $val + incr dirty + } + {^[0-9]+\s+FETCH} { + processfetchline $chan $request_tag $line $literals + incr dirty + } + {^METADATA} { + #e.g + #* METADATA test1 ("/private/specialuse" NIL) + # or + #* METADATA Drafts ("/private/specialuse" {7} + # \Drafts + #) + processmetadataline $chan $request_tag $line $literals + #incr dirty ;#??? review + } + {^MYRIGHTS\s+} { + #line eg: MYRIGHTS INBOX lrswipkxtecdan + #puts stderr "line: $line" + set words [punk::imap4::lib::imapwords $line 3] + if {[dict size $words] == 3} { + set mbox [dict get $words 1 value] + set myrights [dict get $words 2 value] + #set folderinfo($chan,myrights) + } else { + puts stderr "processline unable to make sense of MYRIGHTS response: $line" + puts stderr "words:$words" + } + } + {^CAPABILITY\s+.*} { + #direct response to a CAPABILITY request + #e.g + # cli> 2 CAPABILITY + # svr> * CAPABILITY IMAP4rev1 LITERAL+ ... + # svr> 2 OK Completed + regexp {^CAPABILITY\s+(.*)\s*$} $line => capstring + set info($chan,capability) [split [string toupper $capstring]] + incr dirty + } + {^OK\s+.*} - {^PREAUTH\s+.*} { + #initial * OK or * PREAUTH response - can contain CAPABILITY list + if {[regexp {.*\s+\[CAPABILITY\s+(.*)\]\s*(.*)$} $line => capstring tailstring]} { + #e.g greeting: * OK [CAPABILITY X Y Z ...] server.example.com server ready + set info($chan,capability) [split [string toupper $capstring]] + incr dirty + if {$tailstring ne ""} { + if {[dict get $coninfo $chan debug]} { + puts "([dict get $coninfo $chan hostname])*** WARNING: unprocessed TAIL after CAPABILITY '$line'" + } + } + } + } + {^LIST\s*$} { + #regexp {^([0-9]+)\s+EXISTS} $line => mboxinfo($chan,exists) + regexp {^([0-9]+)\s+EXISTS} $line => val + punk::imap4::_set_mboxinfo $chan exists $val + incr dirty + } + {^SEARCH\s*$} { + # Search tag without list of messages. Nothing found + # so we set an empty list. + #set mboxinfo($chan,found) {} + ::punk::imap4::_set_mboxinfo $chan found {} + } + {^SEARCH\s+.*} { + regexp {^SEARCH\s+(.*)\s*$} $line => foundlist + #set mboxinfo($chan,found) $foundlist + ::punk::imap4::_set_mboxinfo $chan found $foundlist + incr dirty + } + default { + if {[dict get $coninfo $chan debug]} { + puts "([dict get $coninfo $chan hostname])*** WARNING: unprocessed server reply '$line'" + } + } + } + } + + if {[string length [set info($chan,idle)]] && $dirty} { + # ... Notify. + puts stderr "idle is [set info($chan,idle)]" + } + + # if debug and no dirty and untagged line... warning: unprocessed IMAP line + return $tag + } + proc processmetadataline {chan request_tag line literals} { + #our lines here have had the literals separated out + #so we get complete lines where the literal acts as a placeholder + #e.g METADATA Junk ("/private/specialuse" {5}) + #puts stderr "processmetadataline: $line" + set words [punk::imap4::lib::imapwords $line] + set msgbox [dict get $words 1 value] + set resultlist [dict get $words 2 value] + if {[string index $resultlist 0] ne "("} { + protoerror $chan "IMAP: METADATA malformed response '$line'" + } + set itemwords [punk::imap4::lib::imapwords [string range $resultlist 1 end-1]] ;#strip () and process contents + set items [list] + #use lib::imapwords_resolved? + dict for {w wordinfo} $itemwords { + if {[dict get $wordinfo type] eq "literal"} { + set lit [dict get $wordinfo value] + set litinner [string range $lit 1 end-1] + set litinner [string map {+ "" - ""} $litinner] ;#review + set val [::lpop literals 0] + if {[string is integer -strict $litinner] && [string length $val] == $litinner} { + lappend items $val + } else { + protoerror $chan "IMAP: METADATA malformed response ($lit mismatch size of literal [string length $val]) '$line'" + } + } else { + lappend items [dict get $wordinfo value] + } + } + puts stderr "msgbox: $msgbox items: $items" + foreach {annotation val} $items { + #todo -cache? where? + #folderinfo is for last LIST command + # + puts stderr "msgbox: $msgbox annotation: $annotation value: $val" + } + #set match [regexp -nocase {METADATA\s+(\S+){1}\s+(\(.*\))} $line => msgbox items] + #review - can we ever get more than one annotation/val for a metadata request? + #foreach {annotation val} [imaptotcl $chan items literals] { + #} + + } + + # Process untagged FETCH lines. + proc processfetchline {chan request_tag line literals} { + regexp -nocase {([0-9]+)\s+FETCH\s+(\(.*\))} $line => msgnum items + foreach {name val} [imaptotcl $chan items literals] { + set attribname [switch -glob -- [string toupper $name] { + INTERNALDATE {string cat INTERNALDATE} + BODY {string cat BODY} + BODYSTRUCTURE {string cat BODYSTRUCTURE} + {BODY\[HEADER.FIELDS*\]} {string cat fields} + {BODY.PEEK\[HEADER.FIELDS*\]} {string cat fields} + {BODY\[*\]} {string cat $name} + {BODY.PEEK\[*\]} {string cat $name} + HEADER {string cat HEADER} + RFC822.HEADER { + #deprecated in rfc9051 + string cat RFC822.HEADER + } + RFC822.TEXT { + string cat RFC822.TEXT + } + RFC822.SIZE {string cat RFC822.SIZE} + ENVELOPE {string cat ENVELOPE} + FLAGS {string cat FLAGS} + UID {string cat UID} + default { + #protoerror $chan "IMAP: Unknown FETCH item '$name'. Upgrade the software" + #use the raw query as an atribute name + string cat $name + } + }] + + switch -- $attribname { + fields { + set last_fieldname __garbage__ + + set parts [list] + set startline 0 + set nextcrlf [string first \r\n $val] + while {$nextcrlf >= 0} { + lappend parts [string range $val $startline $nextcrlf-1] + set startline [expr {$nextcrlf+2}] + set nextcrlf [string first \r\n $val $startline] + } + lappend parts [string range $val $startline end] + + + foreach f $parts { + #RFC5322 - folding continuation lines cannot contain only white space + if {![string length $f]} continue ;#review + + # Handle multi-line headers. Append to the last header + # if this line starts with a tab character. + if {[string is space [string index $f 0]]} { + #append msginfo($chan,$msgnum,$last_fieldname) " [string range $f 1 end]" + #RFC5322 - modern unfolding involves simply removing any CRLF that is immediately followed by whitespace - not adding an additional space or collapsing leading whitespace. + #This is different to RFC822 unfolding + punk::imap4::_append_msginfo_field $chan $msgnum $request_tag $last_fieldname $f + continue + } + # Process the line searching for a new field. + if {[set fnameidx [string first ":" $f]] == -1} { + protoerror $chan "IMAP: Not a valid RFC822 field '$f'" + } + set fieldname [string tolower [string range $f 0 $fnameidx]] + set last_fieldname $fieldname + set fieldval [string trim \ + [string range $f $fnameidx+1 end]] + #NOTE we can have repeated headers. e.g the old-school Received: header + # or more modern trace headers. + punk::imap4::_set_msginfo_field $chan $msgnum $request_tag $fieldname $fieldval + } + } + default { + #set msginfo($chan,$msgnum,$attribname) $val + punk::imap4::_set_msginfo_field $chan $msgnum $request_tag $attribname $val + } + } + #puts "$attribname -> [string range $val 0 20]" + } + # punk::imap4::_display_msginfo $chan + } + + + # Write a multiline request. The 'request' list must contain + # parts of command and literals interleaved. Literals are at odd + # list positions (1, 3, ...). + proc multiline_request {chan request} { + variable info + variable coninfo + set request_tag [tag $chan] + lset request 0 "$request_tag [lindex $request 0]" + set items [llength $request] + foreach {line literal} $request { + # Send the line + if {[dict get $coninfo $chan debug]} { + puts "([dict get $coninfo $chan hostname])C: $line" + } + puts -nonewline $chan "$line\r\n" + flush $chan + + set info($chan,lastrequest) "$line" + ::punk::imap4::system::add_conlog $chan c $request_tag line [list $line] + + incr items -1 + if {!$items} break + + # Wait for the command continuation response + if {[processline $chan $request_tag] ne {+}} { + protoerror $chan "Expected a command continuation response but got '[lastline $chan]'" + } + + # Send the literal + if {[dict get $coninfo $chan debug]} { + puts "([dict get $coninfo $chan hostname])C> $literal" + } + puts -nonewline $chan $literal + flush $chan + incr items -1 + + #REVIEW + ::punk::imap4::system::add_conlog $chan c $request_tag chunk [list [list length [string length $literal] chunk $literal]] + } + } + + + # Convert IMAP data into Tcl data. Consumes the part of the + # string converted. + # 'literals' is a list with all the literals extracted + # from the original line, in the same order they appeared. + proc imaptotcl {chan datavar literalsvar} { + upvar 1 $datavar data $literalsvar literals + set data [string trim $data] + #don't use backslash esc in switch statement - still wrecks jump table optimisation in Tcl 8.6,9 + switch -- [string index $data 0] { + "{" {imaptotcl_literal $chan data literals} + "(" {imaptotcl_list $chan data literals} + {"} {imaptotcl_quoted $chan data} + 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {imaptotcl_number $chan data} + ")" { + imaptotcl_endlist $chan data;# that's a trick to parse lists + } + "}" - + default {imaptotcl_symbol $chan data} + } + } + + # Extract a literal + proc imaptotcl_literal {chan datavar literalsvar} { + upvar 1 $datavar data $literalsvar literals + if {![regexp {{.*?}} $data match]} { + protoerror $chan "IMAP data format error: '$data'" + } + set data [string range $data [string length $match] end] + # ------ + #set retval [::lpop literals 0] + set retval [lindex $literals 0] + set literals [lrange $literals 1 end] + # ------ + return $retval + } + + # Extract a quoted string + proc imaptotcl_quoted {chan datavar} { + upvar 1 $datavar data + if {![regexp "\\s*?(\".*?\[^\\\\\]\"|\"\")\\s*?" $data => match]} { + protoerror $chan "IMAP data format error: '$data'" + } + set data [string range $data [string length $match] end] + return [string range $match 1 end-1] + } + + # Extract a number + proc imaptotcl_number {chan datavar} { + upvar 1 $datavar data + if {![regexp {^[0-9]+} $data match]} { + protoerror $chan "IMAP data format error: '$data'" + } + set data [string range $data [string length $match] end] + return $match + } + + # Extract a "symbol". Not really exists in IMAP, but there + # are named items, and this names have a strange unquoted + # syntax like BODY[HEADER.FIELD (From To)] and other stuff + # like that. + proc imaptotcl_symbol {chan datavar} { + upvar 1 $datavar data + # matching patterns: "BODY[HEADER.FIELD", + # "HEADER.FIELD", "\Answered", "$Forwarded" + #set pattern {([\w\.]+\[[^\[]+\]|[\w\.]+|[\\\$]\w+)} + #some examples that should also match: + # BODY[] + # BODY[]<0.100> ;#first 100 bytes + # BINARY.PEEK[1]<100.200> + set pattern {([\w\.]+\[[^\[]*\](?:\<[^\>]*\>)*|[\w\.]+|[\\\$]\w+)} + if {![regexp $pattern $data => match]} { + protoerror $chan "IMAP data format error: '$data'" + } + set data [string range $data [string length $match] end] + return $match + } + + # Extract an IMAP list. + proc imaptotcl_list {chan datavar literalsvar} { + upvar 1 $datavar data $literalsvar literals + set list {} + # Remove the first '(' char + set data [string range $data 1 end] + # Get all the elements of the list. May indirectly recurse called + # by [imaptotcl]. + while {[string length $data]} { + set ele [imaptotcl $chan data literals] + if {$ele eq {)}} { + break + } + lappend list $ele + } + return $list + } + + # Just extracts the ")" character alone. + # This is actually part of the list extraction work. + proc imaptotcl_endlist {chan datavar} { + upvar 1 $datavar data + set data [string range $data 1 end] + return ")" + } + + # Creates an IMAP octect-count. + # Used to send literals. + proc literalcount {string} { + return "{[string length $string]}" + } + + # Append a command part to a multiline request + proc multiline_append_command {reqvar cmd} { + upvar 1 $reqvar req + + if {[llength $req] == 0} { + lappend req {} + } + + lset req end "[lindex $req end] $cmd" + } + + # Append a literal to a multiline request. Uses a quoted + # string in simple cases. + proc multiline_append_literal {reqvar lit} { + upvar 1 $reqvar req + + if {![string is alnum $lit]} { + lset req end "[lindex $req end] [literalcount $lit]" + lappend req $lit {} + } else { + multiline_append_command req "\"$lit\"" + } + } + + # Prefix a multiline request with a command. + proc multiline_prefix_command {reqvar cmd} { + upvar 1 $reqvar req + + if {![llength $req]} { + lappend req {} + } + + #Extra space between tag and command can cause NULL command error on at least some servers (cyrus) + #lset req 0 " $cmd[lindex $req 0]" + lset req 0 "$cmd[lindex $req 0]" + } + + # Concat an already created search expression to a multiline request. + proc multiline_concat_expr {reqvar expr} { + upvar 1 $reqvar req + lset req end "[lindex $req end] ([string range [lindex $expr 0] 1 end]" + set req [concat $req [lrange $expr 1 end]] + lset req end "[lindex $req end])" + } + + # Helper for the search command. Convert a programmer friendly expression + # (actually a tcl list) to the IMAP syntax. Returns a list composed of + # request, literal, request, literal, ... (to be sent with + # ::imap4::multiline_request). + proc convert_search_expr {expr} { + set result {} + + while {[llength $expr]} { + switch -glob -- [string toupper [set token [pop0 expr]]] { + + ANSWERED - DELETED - DRAFT - FLAGGED - RECENT - + SEEN - NEW - OLD - UNANSWERED - UNDELETED - + UNDRAFT - UNFLAGGED - + UNSEEN { + multiline_append_command result [string toupper $token] + } + + BODY - CC - FROM - SUBJECT - TEXT - KEYWORD - + BCC { + set wanted [pop0 expr] + multiline_append_command result "$token" + multiline_append_literal result $wanted + } + + OR { + set first [convert_search_expr [pop0 expr]] + set second [convert_search_expr [pop0 expr]] + multiline_append_command result "OR" + multiline_concat_expr result $first + multiline_concat_expr result $second + } + ALL { + #ALL messages in the mailbox: the default inital key for ANDing + #also RETURN ALL - trigger ESEARCH response code? + multiline_append_command result [string toupper $token] + } + FUZZY { + #RFC6203 + set argset [convert_search_expr [pop0 expr]] + multiline_append_command result "FUZZY" + multiline_concat_expr result $argset + } + RETURN { + set options [convert_search_expr [pop0 expr]] + multiline_append_command result "RETURN" + multiline_concat_expr result $options + } + COUNT - MIN - MAX - SAVE { + multiline_append_command result [string toupper $token] + } + NOT { + set e [convert_search_expr [pop0 expr]] + multiline_append_command result "NOT" + multiline_concat_expr result $e + } + + SMALLER - + LARGER { + set len [pop0 expr] + if {![string is integer $len]} { + error "Invalid integer follows '$token' in IMAP search" + } + multiline_append_command result "$token $len" + } + + ON - SENTBEFORE - SENTON - SENTSINCE - SINCE - + BEFORE {error "TODO"} + + UID {error "TODO"} + default { + #*: { + #} + if {[string index $token end] eq ":"} { + set wanted [pop0 expr] + multiline_append_command result "HEADER [string range $token 0 end-1]" + multiline_append_literal result $wanted + } else { + error "Syntax error in search expression: '... $token $expr'" + } + } + } + } + return $result + } + + + # ------------------------------------------------------------------------------------------------------ + #RFC2086 + set rights_2086 [dict create\ + l "lookup (mailbox i- s visible to LIST/LSUB commands)"\ + r "read (SELECT the mailbox, perform CHECK, FETCH, PARTIAL, SEARCH, COPY from mailbox)"\ + s "keep seen/unseen information across sessions (STORE SEEN flag)"\ + w "write (STORE flags other than SEEN and DELETED)"\ + i "insert (perform APPEND, COPY into mailbox)"\ + p "post (send mail to submission address for mailbox, not enforced by IMAP4 itself)"\ + c "create (CREATE new sub-mailboxes in any implementation-defined hierarchy)"\ + d "delete (STORE DELETED flag, perform EXPUNGE)"\ + a "administer (perform SETACL)"\ + ] + #c and d in 2086 have ambiguity + #RFC4314 'obsoleted' them but reclassified them as 'virtual rights' + #For backwards compatibility with clients - more modern servers MUST still include c and d in ACL/MYRIGHTS responses when appropriate. + + + #RFC4314 + set rights_4314 [dict create\ + l {lookup (mailbox is visible to LIST/LSUB commands, SUBSCRIBE mailbox)}\ + r {read (SELECT the mailbox, perform STATUS)}\ + s {keep seen/unseen information across sessions (set or clear \SEEN flag via STORE, also set \SEEN during APPEND/COPY/FETCH BODY[...])}\ + w {write (set or clear flags other than \SEEN and \DELETED via STORE, also set them during APPEND/COPY)}\ + i {insert (perform APPEND, COPY into mailbox)}\ + p {post (send mail to submission address for mailbox, not enforced by IMAP4 itself)}\ + k {create mailboxes (CREATE new sub-mailboxes in any implementation-defined hierarchy, parent mailbox for the new mailbox name in RENAME)}\ + x {delete mailbox (DELETE mailbox, old mailbox name in RENAME)}\ + t {delete messages (set or clear \DELETED flag via STORE, set \DELETED flag during APPEND/COPY)}\ + e {perform EXPUNGE and expunge as a part of CLOSE}\ + a {administer (perform SETACL/DELETEACL/GETACL/LISTRIGHTS)}\ + ] + + #some servers chose 2086 "c" to control the DELETE command + set rights_1 [dict create\ + create {k x}\ + delete {e t}\ + ] + #some servers chose 2086 "d" to control the DELETE command + set rights_2 [dict create\ + create {k}\ + delete {e t x}\ + ] + + # "n" right? RFC? + + set virtual_rights [dict create\ + d delete\ + c create\ + ] + + #TODO + proc rights_info {} { + } + + # ------------------------------------------------------------------------------------------------------ + + + + # Protocol error! Enter the debug mode if ::imap4::debug is true. + # Otherwise just raise the error. + proc protoerror {chan msg} { + variable coninfo + upvar ::punk::imap4::debugmode debugmode + + if {[dict get $coninfo $chan debug] && !$debugmode} { + #todo - cater for async/idle etc - + punk::imap4::debugmode $chan $msg + } else { + error $msg + } + } + + # Little helper for debugmode command. + proc debugmode_info {chan} { + variable coninfo + set h [dict get $coninfo $chan hostname] + puts "($h)Last sent request : '[lastrequest $chan]'" + puts "($h)Last received line: '[lastline $chan]'" + puts "" + } + +} + + +tcl::namespace::eval punk::imap4 { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace punk::imap4}] + #[para] Core API functions for punk::imap4 + #[list_begin definitions] + + variable PUNKARGS + + variable debugmode 0 ;# inside debug mode? usually not. + variable folderinfo + variable mboxinfo + variable msginfo + + + # Debug mode? Don't use it for production! It will print debugging + # information to standard output and run a special IMAP debug mode shell + # on protocol error. + #variable debug [dict create] + + # Version + variable version "2025-02-25" + + # This is where we take state of all the IMAP connections. + # The following arrays are indexed with the connection channel + # to access the per-channel information. + + ### client cached state + array set folderinfo {} ;# list of folders. + set mboxinfo [dict create] ;# selected mailbox info. + set msginfo [dict create] ;#messages info. + + + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::imap4::CONNECT + @cmd -name punk::imap4::CONNECT -help\ + "Open a new IMAP connection and initialise the handler. + Returns the Tcl channel to use in subsequent calls to + the API. Other API commands will return zero on success. + e.g + ${[example { + % set chan [${[B]}CONNECT${[N]} mail.example.com] + sock123aaa456789 + % AUTH_PLAIN $chan user pass + 0 + # ... EXAMINE/CLOSE mailboxes, SEARCH, FETCH etc ... + % LOGOUT $chan + 0 + }]}" + @leaders -min 0 -max 0 + -debug -type boolean -default 0 -help\ + "Display some of the cli/server interaction on stdout + during commands. This can be set or queried using + the 'debugchan $chan ?bool?' command." + -security -nocase 1 -choices {None TLS/SSL STARTTLS} -help\ + "Connection security. + TLS/SSL is recommended (implicit TLS). + + If port is 143 and -security is omitted, then it will + default to STARTTLS. + For any other port, or omitted port, the default for + -security is TLS/SSL. + ie if no channel security is wanted, then -security + should be explicitly set to None." + @values -min 1 -max 2 + hostname -optional 0 -help\ + "Host/IP Address of server. + port may optionally be specified at tail of hostname + after a colon, but not if the following optional port + argument to the command is also supplied and is non-zero. + e.g + server.example.com:143 + [::1]::993 + " + port -optional 1 -type integer -help\ + "Port to connect to. + If port is omitted: + defaults to 143 when -security None or STARTTLS + defaults to 993 when -security TLS/SSL or -security is omitted." + }] + } + proc CONNECT {args} { + set argd [punk::args::parse $args withid ::punk::imap4::CONNECT] + lassign [dict values $argd] leaders opts values received + set hostname [dict get $values hostname] + if {[dict exists $received -security]} { + set opt_security [dict get $opts -security] + } else { + set opt_security unspecified + } + lassign [punk::imap4::lib::parse_address_port $hostname] address addrport + if {![dict exists $received port] || ([dict exists $received port] && [dict get $values port] == 0)} { + set arg_port 0 + } + if {$arg_port != 0 && $addrport != 0} { + puts stderr "Cannot specify port both in port argument as well as in hostname" + puts stderr [punk::args::usage -scheme error ::punk::imap4::CONNECT] + return + } + if {$addrport != 0} { + set specified_port $addrport + } else { + set specified_port $arg_port ;#may still be 0 + } + + if {$specified_port == 0} { + #port unspecified - set based on what/whether -security is specified + switch -- $opt_security { + None - STARTTLS { + set port 143 + } + TLS/SSL - unspecified { + set port 993 + set opt_security TLS/SSL + } + } + } else { + #port is specified and not 0 + set port $specified_port + if {$port == 143} { + if {$opt_security eq "unspecified"} { + set opt_security STARTTLS + } + } else { + #assume any other port is TLS/SSL by default if user didn't specify + if {$opt_security eq "unspecified"} { + set opt_security TLS/SSL + } + } + } + set opt_debug [dict get $opts -debug] + + + upvar ::punk::imap4::proto::info info + upvar ::punk::imap4::proto::coninfo coninfo + #variable use_ssl + if {$opt_debug} { + puts "I: open $address $port (SECURITY=$opt_security)" + } + + switch -- $opt_security { + None { + #insecure + set chan [socket $address $port] + } + STARTTLS { + set connected 0 + #if {"windows" eq $::tcl_platform(platform)} { + # package require twapi + # set insecure_chan [socket $address $port] + # set chan [twapi::starttls $insecure_chan -peersubject mail.11email.com] + # set connected 1 + #} + if {!$connected} { + catch {package require tls} ;#review + if {[info procs ::tls::socket] eq ""} { + error "Package TLS must be loaded for STARTTLS connections." + } + set insecure_chan [::socket $address $port] + chan configure $insecure_chan -translation binary + dict set coninfo $insecure_chan [dict create hostname $address port $port debug $opt_debug security $opt_security] + punk::imap4::proto::initinfo $insecure_chan + punk::imap4::proto::processline $insecure_chan * + set info($insecure_chan,banner) [lastline $insecure_chan] + #return $insecure_chan + #### + if {[STARTTLS $insecure_chan] == 0} { + set chan $insecure_chan; #upgraded + #processline $chan + puts "--> [lastline $chan]" + #get new caps response? + return $chan + } else { + puts stderr "STARTTLS failed" + return + } + } + } + TLS/SSL { + catch {package require tls} ;#review + if {[info procs ::tls::socket] eq ""} { + error "Package TLS must be loaded for implicit TLS connections." + } + #implicit TLS - preferred + set chan [::tls::socket $address $port] + } + } + chan configure $chan -translation binary + dict set coninfo $chan [dict create hostname $address port $port debug $opt_debug security $opt_security] + + # Intialize the connection state array + punk::imap4::proto::initinfo $chan + # Get the banner + punk::imap4::proto::processline $chan * + # Save the banner + set info($chan,banner) [lastline $chan] + return $chan + } + + + lappend PUNKARGS [list { + @id -id ::punk::imap4::CLEANUP + @cmd -name punk::imap4::CLEANUP -help\ + "Destroy an IMAP connection and free the used space." + @values -min 1 -max 1 + chan + }] + proc CLEANUP {chan} { + upvar ::punk::imap4::proto::info info + upvar ::punk::imap4::proto::coninfo coninfo + + variable folderinfo + variable mboxinfo + variable msginfo + + ::close $chan + + array unset folderinfo $chan,* + dict unset mboxinfo $chan + dict unset msginfo $chan + array unset info $chan,* + + dict unset coninfo $chan + return $chan + } + + # STARTTLS + # This is a new proc added to runs the STARTTLS command. Use + # this when tasked with connecting to an unsecure port which must + # be changed to a secure port prior to user login. This feature + # is known as STARTTLS. + # (implicit TLS on a dedicated port is the modern preference, + # but this should be supported in the client API even if many servers + # move away from it) + + proc STARTTLS {chan} { + package require tls + #puts "Starting TLS" + punk::imap4::proto::requirecaps $chan STARTTLS + set clitag [punk::imap4::proto::request $chan STARTTLS] + if {[punk::imap4::proto::getresponse $chan $clitag] != 0} { + #puts "error sending STARTTLS" + return 1 + } + + #puts "TLS import" + set chan [::tls::import $chan] + #puts "TLS handshake" + + #tls::handshake + #returns 0 if handshake still in progress (non-blocking) + #returns 1 if handshake was successful + #throws error if the handshake fails + #REVIEW - should we be calling handshake just once and using tls:status? + #blocking vs non-blocking? + set lim 80 + set i 0 + if {[catch { + while {![::tls::handshake $chan]} { + incr i + if {$i >= 80} { + puts stderr "starttls - client gave up on handshake" + return 1 + } + after 25 + } + if {$i > 0} { + #see if the loop is ever required + puts "called tls::handshake $i times" + } + } errM]} { + puts "err during tls::handshake: $errM" + return 1 + } else { + #Client SHOULD issue capability command after change in TLS status + set capresult [CAPABILITY $chan] ;#updates our capability cache + if {$capresult != 0} { + #generally shouldn't happen - but what is the proper behaviour if it does? + #for now we'll annoy the client - REVIEW + puts stderr "starttls successful - but failed to retrieve new CAPABILITY list" + } + return 0 + } + } + + # ----------------------------------------------------------- + # simple wrappers of proto info + # ----------------------------------------------------------- + # Returns the last error code received. + #proc lastcode {chan} { + # punk::imap4::proto::lastcode $chan + #} + # Returns the last line received from the server. + #proc lastline {chan} { + # punk::imap4::proto::lastline $chan + #} + #proc lastrequest {chan} { + # punk::imap4::proto::lastrequest $chan + #} + # Get the current state + #proc state {chan} { + # punk::imap4::proto::state $chan + #} + namespace import ::punk::imap4::proto::has_capability + namespace import ::punk::imap4::proto::state + namespace import ::punk::imap4::proto::lastline + namespace import ::punk::imap4::proto::lastcode + namespace import ::punk::imap4::proto::lastrequest + namespace import ::punk::imap4::proto::lastrequesttag + # ----------------------------------------------------------- + + proc showlog {chan {tag *}} { + set loglines [punk::imap4::system::get_conlog $chan $tag] + set result "" + foreach info $loglines { + set side [dict get $info side] + switch -- [dict get $info type] { + line { + if {$side eq "c"} { + append result "cli [dict get $info data]" \n + } else { + append result "svr [dict get $info data]" \n + } + } + literal { + if {$side eq "c"} { + append result "cli (lit) [dict get $info data length] bytes [dict get $info data lines] lines" \n + } else { + append result "svr (lit) [dict get $info data length] bytes [dict get $info data lines] lines" \n + } + } + chunk { + package require punk::ansi + set chunkview [punk::ansi::ansistring VIEW -lf 2 [dict get $info data chunk]] + set chunklines [split $chunkview \n] + set paddedview "" + set indent [string repeat " " [string length "cli (chunk) "]] + foreach cl $chunklines { + append paddedview $indent$cl \n + } + if {[string index $paddedview end] eq "\n"} { + set paddedview [string range $paddedview 0 end-1] + } + if {$side eq "c"} { + append result "cli (chunk) [dict get $info data length] bytes\n$paddedview" \n + } else { + append result "svr (chunk) [dict get $info data length] bytes\n$paddedview" \n + } + } + } + append result + } + return $result + } + + #protocol callbacks to api cache namespace + #msginfo + #we need request_tag to determine when we have multiple values for a field - versus subsequent requests which will overwrite + #msgnum is sequence-set? + # todo UIDs separate variable? + #some headers have multiple values (SMTP traces) + #also consider the somewhat contrived use of partials: + # FETCH (BODY[]<0.100> BODY[]<0.10>) + #These are returned in the FETCH response as "BODY[]<0> {100}" and "BODY[]<0> {10}" + #This results in us having a msginfo key of "BODY[]<0>" with 2 values. + # + + proc _set_msginfo_field {chan msgnum request_tag field value} { + variable msginfo + if {![dict exists $msginfo $chan $msgnum]} { + set msgdata [dict create] + } else { + set msgdata [dict get $msginfo $chan $msgnum] + } + if {![dict exists $msgdata $field]} { + set fieldinfo [dict create count 1 values [list $value] request $request_tag] + } else { + #update field info for msgnum + set prev_fieldinfo [dict get $msgdata $field] + set prev_request [dict get $prev_fieldinfo request] + if {$prev_request ne $request_tag} { + #new request - can overwrite + set fieldinfo [dict create count 1 values [list $value] request $request_tag] + } else { + #same request - duplicate header/field e.g Received: header - we need to store all. + set fieldinfo $prev_fieldinfo + dict incr fieldinfo count + dict lappend fieldinfo values $value + } + } + dict set msgdata $field $fieldinfo + dict set msginfo $chan $msgnum $msgdata + #set msginfo($chan,$msgnum,$field) $value + } + proc _append_msginfo_field {chan msgnum request_tag field value} { + variable msginfo + if {![dict exists $msginfo $chan $msgnum $field]} { + error "_append_msginfo_field record for chan:$chan msgnum:$msgnum field:$field not found" + } + set fieldinfo [dict get $msginfo $chan $msgnum $field] + set prev_request [dict get $fieldinfo request] + if {$prev_request ne $request_tag} { + #attempt to append with differing request.. should have been _set_msginfo_field call beforehand.. + error "_append_msginfo_field wrong-request $request_tag for chan:$chan msgnum:$msgnum field:$field with existing request $prev_request" + } + set values [dict get $fieldinfo values] + set lastv [lindex $values end] + append lastv $value + lset values end $lastv + #no change to count or request fields + dict set fieldinfo values $values + + dict set msginfo $chan $msgnum $field $fieldinfo + + #append msginfo($chan,$msgnum,$field) $value + } + proc _display_msginfo {chan} { + variable msginfo + set chandata [dict get $msginfo $chan] + set out "" + dict for {msgseq mdata} $chandata { + dict for {prop propdata} $mdata { + #append out "$msgseq $prop [dict get $propdata values]" + set count [dict get $propdata count] + for {set i 0} {$i < $count} {incr i} { + append out "$msgseq $prop [lindex [dict get $propdata values] $i]" + } + } + } + return $out + } + + proc _set_mboxinfo {chan prop value} { + variable mboxinfo + dict set mboxinfo $chan $prop $value + } + + + + lappend PUNKARGS [list { + @id -id ::punk::imap4::AUTH_LOGIN + @cmd -name punk::imap4::AUTH_LOGIN -help\ + "Login using the IMAP LOGIN command. + " + @leaders -min 1 -max 1 + chan -optional 0 + @opts + -ignorestate -type none -help\ + "Send the LOGIN even if protocol state is not appropriate" + -ignorelogindisabled -type none -help\ + "Ignore the LOGINDISABLED capability + from the server and send LOGIN anyway. + (There should be no need to use this + except for server testing purposes)" + @values -min 2 -max 2 + username + password + }] + proc AUTH_LOGIN {args} { + upvar ::punk::imap4::proto::info info + + set argd [punk::args::parse $args withid ::punk::imap4::AUTH_LOGIN] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set opt_ignorestate [dict exists $received -ignorestate] + set opt_ignorelogindisabled [dict exists $received -ignorelogindisabled] + set username [dict get $values username] + set username [punk::imap4::stringprep::normal_userpass $username] + set password [dict get $values password] + set password [punk::imap4::stringprep::normal_userpass $password] + + if {!$opt_ignorelogindisabled} { + if {[punk::imap4::proto::has_capability $chan LOGINDISABLED]} { + error "IMAP SERVER has advertised the capability LOGINDISABLED. Try another mechanism, or ensure TLS or STARTTLS is being used." + } + } + if {!$opt_ignorestate} { + punk::imap4::proto::requirestate $chan NOAUTH + } + set rtag [punk::imap4::proto::request $chan [list LOGIN $username $password]] + if {[punk::imap4::proto::getresponse $chan $rtag] != 0} { + return 1 + } + set info($chan,state) AUTH + return 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::imap4::AUTH_PLAIN + @cmd -name punk::imap4::AUTH_PLAIN -help\ + "PLAIN SASL Authentication mechanism. + + This uses the 'initial response' to send + the base64 encoded authzn authn password + in the same line as AUTHENTICATE PLAIN. + + It does not support the negotiation version + of PLAIN where AUTHENTICATE PLAIN is sent, + and the client sends the credentials after + getting a continuation (+) from the server." + @leaders -min 1 -max 1 + chan -optional 0 + @opts + -ignorestate -type none -help\ + "Send the AUTHENTICATE even if protocol state is not appropriate" + -authorization -type string -default "" -help\ + "authorization identity (identity to act as) + Usually it is not necessary to provide an + authorization identity - as it will be derived + from the credentials. ie from the + 'authentication identity' which is the username. + " + @values -min 2 -max 2 + username -help\ + "Authentication identity" + password + }] + proc AUTH_PLAIN {args} { + upvar ::punk::imap4::proto::info info + set argd [punk::args::parse $args withid ::punk::imap4::AUTH_PLAIN] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set opt_ignorestate [dict exists $received -ignorestate] + set opt_authorization [dict get $opts -authorization] + if {$opt_ignorestate} { + set allowstates * + } else { + set allowstates NOAUTH + } + set username [dict get $values username] + set username [punk::imap4::stringprep::normal_userpass $username] + set password [dict get $values password] + set password [punk::imap4::stringprep::normal_userpass $password] + package require base64 + set b64_creds [base64::encode $opt_authorization\0$username\0$password] + if {[punk::imap4::proto::simplecmd $chan -validstates $allowstates AUTHENTICATE PLAIN $b64_creds]} { + return 1 + } + set info($chan,state) AUTH + return 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::imap4::MYRIGHTS + @cmd -name punk::imap4::MYRIGHTS -help\ + "Get the set of rights that the current user + has to the mailbox. + + incomplete + Currently need debug mode or showlog + to see results" + @leaders -min 1 -max 1 + chan + @values -min 0 -max 1 + mailbox -default INBOX + }] + proc MYRIGHTS {args} { + set argd [punk::args::parse $args withid ::punk::imap4::MYRIGHTS] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + if {[punk::imap4::proto::simplecmd $chan MYRIGHTS $mailbox] != 0} { + return 1 + } + #todo - store in appropriate cache - retrieve if -inline specified? + return 0 + } + lappend PUNKARGS [list { + @id -id ::punk::imap4::GETACL + @cmd -name punk::imap4::GETACL -help\ + "Get ACL for a mailbox. + The current user must have permission to administer + the mailbox (the \"a\" right) to perform ACL commands + ie SETACL/GETACL/DELETEACL/LISTRIGHTS + + As opposed to MYRIGHTS, GETACL will return info + about other users' rights on the mailbox + (including current user) + + incomplete + Currently need debug mode or showlog + to see results" + @leaders -min 1 -max 1 + chan + @values -min 0 -max 1 + mailbox -default INBOX + }] + proc GETACL {args} { + set argd [punk::args::parse $args withid ::punk::imap4::GETACL] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + if {[punk::imap4::proto::simplecmd $chan GETACL $mailbox] != 0} { + return 1 + } + #todo - store in appropriate cache - retrieve if -inline specified? + return 0 + } + lappend PUNKARGS [list { + @id -id ::punk::imap4::SETACL + @cmd -name punk::imap4::SETACL -help\ + "Set ACL for a specified user on a mailbox. + The current user must have permission to administer + the mailbox (the \"a\" right) to perform ACL commands + ie SETACL/GETACL/DELETEACL/LISTRIGHTS" + @leaders -min 1 -max 1 + chan + @values -min 3 -max 3 + mailbox + user + rights -help\ + "A rights string consisting of zero or more rights + characters (lowercase) optionally beginning with a + \"+\" or \"-\" + e.g SETACL projectfolder other.user +cda + If the string starts with a plus, the following + rights are added to any existing rights for the + specified user. + If the string starts with a minus, the following + rights are removed from any existing rights for + the specified user. + If the string does not start with a plus or minus, + the rights replace any existing rights for the + specified user. + " + }] + proc SETACL {args} { + set argd [punk::args::parse $args withid ::punk::imap4::SETACL] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + set user [dict get $values user] + set rights [dict get $values rights] + if {[punk::imap4::proto::simplecmd $chan SETACL $mailbox $user $rights] != 0} { + return 1 + } + #todo - update appropriate cache? + return 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::imap4::LISTRIGHTS + @cmd -name punk::imap4::LISTRIGHTS -help\ + "Get information about the required rights + and the optional rights for a specified user + on this mailbox. + The required rights (a possibly empty string) + are the rights that will always be granted to that + user in the mailbox. + The optional rights are rights that CAN be granted. + + incomplete + Currently need debug mode or showlog + to see results" + @leaders -min 1 -max 1 + chan + @values -min 0 -max 2 + mailbox -default INBOX + user -default anyone + }] + proc LISTRIGHTS {args} { + set argd [punk::args::parse $args withid ::punk::imap4::LISTRIGHTS] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + set user [dict get $values user] + if {[punk::imap4::proto::simplecmd $chan LISTRIGHTS $mailbox $user] != 0} { + return 1 + } + #todo - store in appropriate cache - retrieve if -inline specified? + return 0 + } + + + + lappend PUNKARGS [list { + @id -id ::punk::imap4::SELECT + @cmd -name punk::imap4::SELECT -help\ + {Selects a mailbox so that messages in the mailbox can be + accessed. + + Only one mailbox can be selected at a time in a connection. + This is termed a "session". + Simultaneous access to multiple mailboxes requires multiple + connections. The SELECT command automatically deselects any + currently selected mailbox before attempting the new + selection. Consequently, if a mailbox is selected and a + SELECT command that fails is attempted, no mailbox is + selected. + } + @leaders -min 1 -max 1 + chan + @values -min 0 -max 1 + mailbox -default INBOX -help\ + {To supply a mailbox name with spaces + The value will need to be enclosed with + double quotes - and these quotes need to + be sent to the server. Enclose in curly + braces to ensure this. + e.g + SELECT $ch {"Deleted Items"} + } + }] + proc SELECT {args} { + set argd [punk::args::parse $args withid ::punk::imap4::SELECT] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + + selectmbox $chan SELECT $mailbox + } + + lappend PUNKARGS [list { + @id -id ::punk::imap4::EXAMINE + @cmd -name punk::imap4::EXAMINE -help\ + {The EXAMINE command is identical to SELECT and returns the + same output; however, the selected mailbox is identified as + read-only. No changes to the permanent state of the mailbox, + including per-user state, are permitted.} + @leaders -min 1 -max 1 + chan + @values -min 0 -max 1 + #todo - share argdefs more! + mailbox -default INBOX -help\ + {To supply a mailbox name with spaces + The value will need to be enclosed with + double quotes - and these quotes need to + be sent to the server. Enclose in curly + braces to ensure this. + e.g + SELECT $ch {"Deleted Items"} + } + }] + proc EXAMINE {args} { + set argd [punk::args::parse $args withid ::punk::imap4::EXAMINE] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + + selectmbox $chan EXAMINE $mailbox + } + # General function for selection. + proc selectmbox {chan cmd mailbox} { + upvar ::punk::imap4::proto::info info + variable mboxinfo + variable msginfo + + punk::imap4::proto::requirestate $chan {AUTH SELECT} + # Clean info about the previous mailbox if any, + # but save a copy to restore this info on error. + #set savedmboxinfo [array get mboxinfo $chan,*] + #array unset mboxinfo $chan,* + dict unset mboxinfo $chan + #msginfo is based on seq-number - which is per mailbox, so we have to clear it for now. + #todo - keep cache of per mailbox msginfo even when based on seq-number? + dict unset msginfo $chan + #review - keep cache of uid based msginfo - where? + set rtag [punk::imap4::proto::request $chan "$cmd $mailbox"] + if {[punk::imap4::proto::getresponse $chan $rtag] != 0} { + #array set mboxinfo $savedmboxinfo + set info($chan,state) AUTH + return 1 + } + + #TODO - state SELECT vs EXAMINE? + set info($chan,state) SELECT + + # Set the new name as mbox->current. + #set mboxinfo($chan,current) $mailbox + _set_mboxinfo $chan current $mailbox + return 0 + } + + #parse_seq-range - parse a seq-range from a sequence-set + #sequence-set + #Example: a message sequence number set of + # ; 2,4:7,9,12:* for a mailbox with 15 messages is + # ; equivalent to 2,4,5,6,7,9,12,13,14,15 + + + #parse_seq-range should be used primarily for examining sequence-set members + #when we want to determine the applicable ranges e.g to lookup cached info for each message + #When sending a sequence-set to the server, we can use parse_seq-range to check for errors, + #but we shouldn't be 'expanding' a valid sequence-set being sent to the server. + #We don't accept the : or :n or n: syntax accepted by the tcllib imap4 library + # - because the more explicit syntax specified in the IMAP RFCs is preferred + #(with possible * special value) + proc parse_seq-range {chan range} { + if {[string first , $range] >=0} { + error "parse_seq_range supplied value '$range' appears to be a sequence-set, not a seq-range or seq-number" + } + set rangelist [split $range :] + switch -- [llength $rangelist] { + 1 { + if {$range eq "*"} { + set start [mboxinfo $chan exists] + set end $start + } else { + set start $range + set end $range + } + if {![punk::imap4::proto::is_imap_nznumber $start] || ![punk::imap4::proto::is_imap_nznumber $end]} { + error "parse_seq-range Invalid range '$range'" + } + } + 2 { + lassign $rangelist start end + if {$start eq "*" && $end eq "*"} { + set end [mboxinfo $chan exists] + set start $end + } elseif {$start eq "*"} { + set start [mboxinfo $chan exists] + } elseif {$end eq "*"} { + set end [mboxinfo $chan exists] + } + if {![punk::imap4::proto::is_imap_nznumber $start] || ![punk::imap4::proto::is_imap_nznumber $end]} { + error "parse_seq-range Invalid range '$range'" + } + } + default { + error "parse_seq-range Invalid range '$range'" + } + } + return [list $start $end] + } + + #old_parse_seq-range + # Parse an IMAP seq-range, store 'start' and 'end' in the + # named vars. If the first number of the range is omitted, + # 1 is assumed. If the second number of the range is omitted, + # the value of "exists" of the current mailbox is assumed. + # + # So : means all the messages. + proc old_parse_seq-range {chan range startvar endvar} { + + upvar $startvar start $endvar end + set rangelist [split $range :] + switch -- [llength $rangelist] { + 1 { + if {![string is integer $range]} { + error "Invalid range" + } + set start $range + set end $range + } + 2 { + foreach {start end} $rangelist break + if {![string length $start]} { + set start 1 + } + if {![string length $end]} { + set end [mboxinfo $chan exists] + } + if {![string is integer $start] || ![string is integer $end]} { + error "Invalid range" + } + } + default { + error "Invalid range" + } + } + } + + lappend PUNKARGS [list { + @id -id ::punk::imap4::FETCH + @cmd -name punk::imap4::FETCH -help\ + "Fetch a number of attributes from messages. + A mailbox must be SELECTed first and an appropriate + sequence-set supplied for the message(s) of interest." + @leaders -min 1 -max 1 + chan + @opts + -inline -type none + @values -min 2 -max -1 + #todo - use same sequence-set definition across argdefs + sequence-set -help\ + "Message sequence set. + 1 is the lowest valid sequence number. + * represents the maximum message sequence number + in the mailbox. + e.g + 1 + 2:2 + 1:3 + 3,5,9:10 + 1,10:* + *:5 + * + " + queryitems -default {} -help\ + "Some common FETCH queries are shown here, but + this list isn't exhaustive."\ + -multiple 1 -optional 0 -choiceprefix 0 -choicerestricted 0 -choicecolumns 2 -choices { + ALL FAST FULL BODY BODYSTRUCTURE ENVELOPE FLAGS INTERNALDATE + SIZE RFC822.SIZE + UID + TEXT HEADER BODY[] BINARY[] BINARY.SIZE[] + } -choicelabels { + ALL\ + " Macro equivalent to: + (FLAGS INTERNALDATE RFC822.SIZE ENVELOPE) + This is only valid by itself. + No other queryitems should be provided" + FAST\ + " Macro equivalent to: + (FLAGS INTERNALDATE RFC822.SIZE) + This is only valid by itself. + No other queryitems should be provided" + FULL\ + " Macro equivalent to: + (FLAGS INTERNALDATE RFC822.SIZE ENVELOPE BODY) + This is only valid by itself. + No other queryitems should be provided." + BODY\ + " Non-extensible form of BODYSTRUCTURE" + BODYSTRUCTURE\ + " A parenthesized list that describes the MIME-IMB + body structure of a message." + {BODY[]}\ + { This retrieves the entire body including headers. + (RFC5322 expression of the entire message) + This implicitly sets the \Seen flag, as do other + FETCH BODY[...] operations. Ensure the mailbox is + opened using EXAMINE, or use BODY.PEEK[...] to avoid + this.} + {BINARY[]}\ + { Requests that the specified section be transmitted + after performing decoding of the section's + Content-Transfer-Encoding. + Like BODY[...] it will set the \Seen flag and also + has a BINARY.PEEK[...] alternate form. + Can only be requested for leaf body parts: those that + have media types other than multipart/*, + message/rfc822, or message/global.} + {BINARY.SIZE[]}\ + { Requests the decoded size fo the section (i.e , the + size to expect in response to the corresponding + FETCH BINARY request). + Only available for leaf body parts. + Can be an expensive operation on some servers. + } + RFC822.SIZE\ + { Number of octets in the message when the message + is expressed in RFC5322 format. SHOULD match the + result of a "FETCH BODY[]" command. Some servers + may store with different internal format and store + the size to avoid recalculation.} + SIZE\ + { Client-side alias for RFC822.SIZE for consistency + with tcllib IMAP4. Consider deprecating.} + ENVELOPE\ + " The envelope structure of the message. + Computed by the server by parsing the RFC5322 + header defaulting various fields as necessary" + INTERNALDATE\ + " The internal date of the message. + (Suitable as date arg for APPEND if copying a msg + from one server to another)" + } + }] + proc FETCH {args} { + variable msginfo + set argd [punk::args::parse $args withid ::punk::imap4::FETCH] + lassign [dict values $argd] leaders opts values received + + set chan [dict get $leaders chan] + set opt_inline [dict exists $received -inline] + set sequenceset [dict get $values sequence-set] + set query_items [dict get $values queryitems] + + punk::imap4::proto::requirestate $chan SELECT + + #parse each seqrange to give it a chance to raise error for bad values + foreach seqrange [split $sequenceset ,] { + parse_seq-range $chan $seqrange + } + + set items {} + set hdrfields {} + + #3 macros that should be used on own, not in conjunction with other macros + # or data items: + #ALL - equiv to (FLAGS INTERNALDATE RFC822.SIZE ENVELOPE) + #FAST - equiv to (FLAGS INTERNALDATE RFC822.SIZE) + #FULL - equiv to (FLAGS INTERNALDATE RFC822.SIZE ENVELOPE BODY) + + #todo "$" data-item ? + + foreach data_item $query_items { + set DATA_ITEM [string toupper $data_item] + switch -- $DATA_ITEM { + ALL - FAST - FULL {lappend items $DATA_ITEM} + BODY - + BODYSTRUCTURE - + ENVELOPE - + FLAGS - + INTERNALDATE - + RFC822.SIZE - + UID {lappend items $DATA_ITEM} + SIZE { + #Alias in this client only - compat with tcllib::imap4 + lappend items RFC822.SIZE + } + TEXT { + #IMAP4rev2 deprecated + lappend items RFC822.TEXT + } + HEADER { + #IMAP4rev2 deprecated + lappend items RFC822.HEADER + } + default { + if {[string index $data_item end] eq ":"} { + #*: {lappend hdrfields $w} + lappend hdrfields $data_item + } else { + # Fixme: better to raise an error here? + #lappend hdrfields $data_item: + + #pass through + lappend items $data_item + } + } + } + } + + if {[llength $hdrfields]} { + #set item {BODY[HEADER.FIELDS (} ;#will set /seen flag + set item {BODY.PEEK[HEADER.FIELDS (} + foreach field $hdrfields { + append item [string toupper [string range $field 0 end-1]] { } + } + set item [string range $item 0 end-1] + append item {)]} + lappend items $item + } + + #The server-side macros ALL FAST FULL (at least on cyrus server) can't be bracketed and must appear alone + #if we detect any of these, take the first and - override any other entries + foreach m {ALL FAST FULL} { + if {$m in $query_items} { + set items $m + break + } + } + + # Send the request + if {[llength $items] == 1} { + #if {[lindex $items 0] in {ALL FAST FULL}} {} + #pass as is - not bracketed list + #the 3 macros are known NOT to be understood as (ALL) (FAST) (FULL) on cyrus at least + #Other single atoms such as INTERNALDATE,ENVELOPE,FLAGS etc can be passed as e.g (INTERNALDATE) or INTERNALDATE + #from RFC9051: + #---------------- + #fetch = "FETCH" SP sequence-set SP ( + # "ALL" / "FULL" / "FAST" / + # fetch-att / "(" fetch-att *(SP fetch-att) ")") + #fetch-att = "ENVELOPE" / "FLAGS" / "INTERNALDATE" / + # "RFC822.SIZE" / + # "BODY" ["STRUCTURE"] / "UID" / + # "BODY" section [partial] / + # "BODY.PEEK" section [partial] / + # "BINARY" [".PEEK"] section-binary [partial] / + # "BINARY.SIZE" section-binary + #---------------- + # + #don't wrap a single element in brackets - it may already be bracketed by the caller + #for ALL FAST FULL - which can only occur on their own, bracketing is not allowed anyway. + set request_tag [punk::imap4::proto::request $chan "FETCH $sequenceset [lindex $items 0]"] + } else { + set request_tag [punk::imap4::proto::request $chan "FETCH $sequenceset ([join $items])"] + } + if {[punk::imap4::proto::getresponse $chan $request_tag] != 0} { + if {$opt_inline} { + # Should we throw an error here? + return "" + } + return 1 + } + + if {!$opt_inline} { + return 0 + } + + # -inline processing begins here + #The fetch queries can be serverside-macros or even custom compound + #queries such as: + # {BODY[HEADER.FIELDS (SUBJECT TO ...)]} + # {BINARY[1]} + #We should base our -inline response on the returned fields - not one per input query element. + #This is divergent from tcllib::imap4 which returned untagged lists that the client would match + #based on assumed simple value queries such as specific properties and headers that are individually specified. + set fetchresult [dict create] + for {set i $start} {$i <= $end} {incr i} { + set flagdict [dict get $msginfo $chan $i] + #extract the fields that were added for this request_tag only + dict for {f finfo} $flagdict { + if {[dict get $finfo request] eq $request_tag} { + #lappend msgrecord [list $f $finfo] + dict set fetchresult $f $finfo + } + } + } + return $fetchresult + + + #return $mailinfo + set mailinfo {} + set fields [list] + #todo - something better + foreach itm $items { + if {$itm ni {ALL FAST FULL}} { + lappend fields $itm + } + } + #lappend fields {*}$hdrfields + set fields [list {*}$fields {*}$hdrfields] + for {set i $start} {$i <= $end} {incr i} { + set mailrec [list] + foreach {f} $fields { + #lappend mailrec [msginfo $chan $i $f ""] + set finfo [msginfo $chan $i $f ""] + if {$finfo eq ""} { + lappend mailrec "count 0 field $f values {} request $request_tag" + } else { + set count [dict get $finfo count] + if {$count == 1} { + lappend mailrec [lindex [dict get $finfo values] 0] + } else { + #review + set values [dict get $finfo values] + lappend mailrec [list items $count values $values] + } + } + #lappend mailrec [dict get $finfo values] + } + lappend mailinfo $mailrec + } + return $mailinfo + } + + # Get information (previously collected using fetch) from a given message. + # If the 'info' argument is omitted or a null string, the full list + # of information available for the given message is returned. + # + # If the required information name is suffixed with a ? character, + # the command requires true if the information is available, or + # false if it is not. + proc msginfo {chan msgid args} { + variable msginfo + + switch -- [llength $args] { + 0 { + set info {} + } + 1 { + set info [lindex $args 0] + set use_defval 0 + } + 2 { + set info [lindex $args 0] + set defval [lindex $args 1] + set use_defval 1 + } + default { + error "msginfo called with bad number of arguments! Try msginfo channel messageid ?info? ?defaultvalue?" + } + } + #set info [string tolower $info] + # Handle the missing info case + if {![string length $info]} { + set minfo [dict get $msginfo $chan $msgid] + return [dict keys $minfo] + } + + if {[string index $info end] eq {?}} { + return [dict exists $msginfo $chan $msgid [string range $info 0 end-1]] + #set info [string range $info 0 end-1] + #return [info exists msginfo($chan,$msgid,$info)] + } else { + if {![dict exists $msginfo $chan $msgid $info]} { + if {$use_defval} { + return $defval + } else { + error "No such information '$info' available for message id '$msgid'" + } + } + set fieldinfo [dict get $msginfo $chan $msgid $info] + return $fieldinfo + #return $msginfo($chan,$msgid,$info) + } + } + + # Get information on the currently selected mailbox. + # If the 'info' argument is omitted or a null string, the full list + # of information available for the mailbox is returned. + # + # If the required information name is suffixed with a ? character, + # the command requires true if the information is available, or + # false if it is not. + proc mboxinfo {chan {info {}}} { + variable mboxinfo + + # Handle the missing info case + if {![string length $info]} { + #set list [array names mboxinfo $chan,*] + set minfo [dict get $mboxinfo $chan] + return [dict keys $minfo] + } + + set info [string tolower $info] + set minfo [dict get $mboxinfo $chan] + if {[string index $info end] eq {?}} { + return [dict exists $minfo [string range $info 0 end-1]] + } else { + if {![dict exists $minfo $info]} { + error "No such information '$info' available for the current mailbox" + } + return [dict get $minfo $info] + } + } + + # Get information on the last folders list. + # If the 'info' argument is omitted or a null string, the full list + # of information available for the folders is returned. + # + # If the required information name is suffixed with a ? character, + # the command requires true if the information is available, or + # false if it is not. + proc folderinfo {chan {info {}}} { + variable folderinfo + + # Handle the missing info case + if {![string length $info]} { + set list [array names folderinfo $chan,*] + set availinfo {} + foreach l $list { + lappend availinfo [string range $l \ + [string length $chan,] end] + } + return $availinfo + } + + set info [string tolower $info] + if {[string index $info end] eq {?}} { + set info [string range $info 0 end-1] + return [info exists folderinfo($chan,$info)] + } else { + if {![info exists folderinfo($chan,$info)]} { + error "No such information '$info' available for the current folders" + } + return $folderinfo($chan,$info) + } + } + + #namespace import ::punk::imap4::proto::CAPABILITY + + lappend PUNKARGS [list { + @id -id ::punk::imap4::CAPABILITY + @cmd -name punk::imap4::CAPABILITY -help\ + "send CAPABILITY command to the server. + The cached results can be checked with + the punk::imap4::has_capability command." + @leaders -min 1 -max 1 + chan -optional 0 + @opts + @values -min 0 -max 0 + }] + # Get capabilties + proc CAPABILITY {args} { + set argd [punk::args::parse $args withid ::punk::imap4::CAPABILITY] + set chan [dict get $argd leaders chan] + set rtag [punk::imap4::proto::request $chan "CAPABILITY"] + if {[punk::imap4::proto::getresponse $chan $rtag]} { + return 1 + } + return 0 + } + + + lappend PUNKARGS [list { + @id -id ::punk::imap4::NOOP + @cmd -name punk::imap4::NOOP -help\ + "NOOP command. May get information as untagged data. + The NOOP command always succeeds. It does nothing. + + Since any command can return a status update as untagged data, + the NOOP command can be used as a periodic poll for new messages + or message status updates during a period of inactivity + (The IDLE command should be used instead of NOOP if real-time + updates to mailbox state are desirable). + + The NOOP command can also be used to reset any inactivity + autologout timer on the server. + " + @leaders -min 1 -max 1 + chan -optional 0 + @opts + @values -min 0 -max 0 + }] + proc NOOP {args} { + set argd [punk::args::parse $args withid ::punk::imap4::NOOP] + set chan [dict get $argd leaders chan] + punk::imap4::proto::simplecmd $chan NOOP + } + + # CHECK. Flush to disk. + lappend PUNKARGS [list { + @id -id ::punk::imap4::CHECK + @cmd -name punk::imap4::CHECK -help\ + "OBSOLETED in RFC9051. + NOOP should generally be used instead. + + The CHECK command requests a checkpoint of the currently + selected mailbox. + This was for implementation dependent housekeeping associated + with the mailbox. + " + @leaders -min 1 -max 1 + chan -optional 0 + @opts + @values -min 0 -max 0 + }] + proc CHECK {args} { + set argd [punk::args::parse $args withid ::punk::imap4::CHECK] + set chan [dict get $argd leaders chan] + punk::imap4::proto::simplecmd $chan -validstates {SELECT} CHECK + } + + # Close the mailbox. Permanently removes \Deleted messages and return to + # the AUTH state. + lappend PUNKARGS [list { + @id -id ::punk::imap4::CLOSE + @cmd -name punk::imap4::CLOSE -help\ + {The CLOSE command permanently removes all messages that have the + \Deleted flag set from the currently selected mailbox, and it returns + to the authenticated state from the selected state. No untagged + EXPUNGE responses are sent. + + No messages are removed, and no error is given, if the mailbox is + selected by an EXAMINE command or is otherwise selected as read-only. + + Even if a mailbox is selected, a SELECT, EXAMINE, or LOGOUT command + MAY be issued without previously issuing a CLOSE command. The + SELECT, EXAMINE, and LOGOUT commands implicitly close the currently + selected mailbox without doing an expunge. However, when many + messages are deleted, a CLOSE-LOGOUT or CLOSE-SELECT sequence is + considerably faster than an EXPUNGE-LOGOUT or EXPUNGE-SELECT because + no untagged EXPUNGE responses (which the client would probably + ignore) are sent.} + @leaders -min 1 -max 1 + chan -optional 0 + @opts + @values -min 0 -max 0 + }] + proc CLOSE {args} { + set argd [punk::args::parse $args withid ::punk::imap4::CLOSE] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + + upvar ::punk::imap4::proto::info info + variable mboxinfo + + if {[punk::imap4::proto::simplecmd $chan -validstates {SELECT} CLOSE]} { + return 1 + } + + #array set mboxinfo {} ;#JMN + set mboxinfo [dict create] + set info($chan,state) AUTH + return 0 + } + lappend PUNKARGS [list { + @id -id ::punk::imap4::UNSELECT + @cmd -name punk::imap4::UNSELECT -help\ + "Sends UNSELECT command to server. + Similar to CLOSE - but doesn't expunge messages with the \Deleted flag. + + IMAP RFC9051 + ------------------------------------------------------------------------ + Arguments: none + Responses: no specific responses for this command + Result: + OK - unselect completed, now in authenticated state + BAD - no mailbox selected, or argument supplied but none permitted + + The UNSELECT command frees a session's resources associated with the + selected mailbox and returns the server to the authenticated state. + This command performs the same actions as CLOSE, except that no messages + are permanently removed from the currently selected mailbox. + + Example: + + C: A342 UNSELECT + S: A342 OK Unselect completed + ------------------------------------------------------------------------ + see also RFC3691 - IMAP UNSELECT command + " + @leaders -min 1 -max 1 + chan -optional 0 + @opts + -ignorestate -type none -help\ + "Send the UNSELECT even if protocol state is not appropriate" + @values -min 0 -max 0 + }] + proc UNSELECT {args} { + upvar ::punk::imap4::proto::info info + variable mboxinfo + + set argd [punk::args::parse $args withid ::punk::imap4::UNSELECT] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set opt_ignorestate [dict exists $received -ignorestate] + if {$opt_ignorestate} { + set allowstates * + } else { + set allowstates SELECT + } + if {![punk::imap4::proto::has_capability $chan UNSELECT]} { + error "IMAP SERVER has NOT advertised the capability UNSELECT. Try CLOSE instead." + } + + #todo - limit to imap4 rev2+? + if {[punk::imap4::proto::simplecmd $chan -validstates $allowstates UNSELECT]} { + return 1 + } + #array set mboxinfo {} ;#JMN + set mboxinfo [dict create] + set info($chan,state) AUTH + return 0 + } + + proc NAMESPACE {chan} { + punk::imap4::proto::simplecmd $chan NAMESPACE + } + + # Create a new mailbox. + #todo - allow creation with specialuse metadata if + # CREATE-SPECIAL-USE capability is present + lappend PUNKARGS [list { + @id -id "::punk::imap4::CREATE" + @cmd -name "punk::imap4::CREATE" -help\ + "Create a mailbox with the given name. + It is an error to attempt to create INBOX + or a name that refers to an existing mailbox. + Servers will generally allow creation of a + hierarchy of mailboxes if the mailbox separator + is within the name." + @leaders -min 1 -max 1 + chan + @opts + @values -min 1 -max 1 + mailbox + }] + proc CREATE {args} { + set argd [punk::args::parse $args withid ::punk::imap4::CREATE] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + + punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT} CREATE $mailbox + } + + + # RFC 5464 The IMAP METADATA Extension + # ------------------------------------------------------------ + # - RFC6154 IMAP LIST Extension for Special-use Mailboxes + # - other mailbox 'annotations' ? + # - relevant CAPS: SPECIAL-USE CREATE-SPECIAL-USE LIST-EXTENDED + # ------------------------------------------------------------ + lappend PUNKARGS [list { + @id -id "::punk::imap4::GETMETADATA" + @cmd -name "punk::imap4::GETMETDATA" -help\ + "Get metadata on named mailbox, or server annotations + if empty-string provided instead of mailbox name." + @leaders -min 1 -max 1 + chan + @opts + @values -min 2 -max 2 + mailbox -help\ + {Mailbox name or empty string {""} for server annotations} + annotation -choicerestricted 0 -choiceprefix 0 -help\ + "May include glob character *"\ + -choices { + /private/specialuse /private/squat /private/sieve /private/sharedseen /private/comment + /private/expire /private/news2mail /private/pop3showafter + } -help\ + "Annotation is a string beginning with /private/ or /shared/ + Check specific server for supported mailbox annotations. + " + }] + proc GETMETADATA {args} { + #on cyrus at least, annotation must begin with /shared or /private + #e.g /private/specialuse + #C: GETMETDATA "Foldername" /private/specialuse + #S: * METADATA "Foldername" (/private/specialuse NIL) + #S: OK Completed + #or + #C: GETMETDATA "Junk" /private/specialuse + #S: * METADATA "Foldername" (/private/specialuse {5} + #S: \Junk + #S: ) + #S: OK Completed + set argd [punk::args::parse $args withid ::punk::imap4::GETMETADATA] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + set annotation [dict get $values annotation] + + set annotation [string trim $annotation] + if {![string match "/private/?*" $annotation] && ![string match "/shared/?*" $annotation]} { + #cyrus IMAP enforces this anyway.. others? can we ever send just the following? GETMETADATA name * + error "GETMETADATA annotation must begin with /shared/ or /private/" + } + punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT EXAMINE} GETMETADATA $mailbox $annotation + } + + lappend PUNKARGS [list { + @id -id "::punk::imap4::SETMETADATA" + @cmd -name "punk::imap4::SETMETDATA" -help\ + "Set metadata on mailbox name. + + If an empty string is provided instead of the + mailbox name - the annotation is applied at + the server level. Users may be able to set + /private or /shared annotations at the server + level depending on how the server restricts + them." + @leaders -min 1 -max 1 + chan + @opts + -ignorestate -type none + @values -min 3 -max 3 + mailbox + annotation -choicerestricted 0 -choices { + /private/specialuse /private/squat /private/sieve /private/sharedseen /private/comment + /private/expire /private/news2mail /private/pop3showafter + } -help\ + "Annotation is a string beginning with /private/ or /shared/ + Check specific server for supported mailbox annotations. + " + value -help\ + "Pass the empty string or NIL to unset/delete the annotation" + }] + proc SETMETADATA {args} { + set argd [punk::args::parse $args withid ::punk::imap4::SETMETADATA] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + if {[dict exists $received -ignorestate]} { + set ignorestate 1 + } else { + set ignorestate 0 + } + set mailbox [dict get $values mailbox] + set annotation [dict get $values annotation] + set value [dict get $values value] + + set annotation [string trim $annotation] + if {![string match /private/?* $annotation] && ![string match /shared/?* $annotation]} { + error "SETMETADATA annotation must begin with /shared/ or /private/" + } + if {$ignorestate} { + set validstates * + } else { + set validstates {AUTH SELECT EXAMINE} + } + if {$value in [list "" NIL]} { + punk::imap4::proto::simplecmd $chan -validstates $validstates SETMETADATA $mailbox "($annotation NIL)" + } else { + punk::imap4::proto::simplecmd $chan -validstates $validstates SETMETADATA $mailbox "($annotation \"$value\")" + } + } + # ------------------------------------------------------------ + + lappend PUNKARGS [list { + @id -id "::punk::imap4::DELETE" + @cmd -name "punk::imap4::DELETE" -help\ + "Permanently delete the mailbox with the + given name. + Server behaviour may vary with regards + to when/if mailboxes with sub-boxes can + be deleted. + If the mailbox is successfully deleted, + all messages in that mailbox are removed. + Todo - document more." + @leaders -min 1 -max 1 + chan + @opts + @values -min 1 -max 1 + mailbox + }] + proc DELETE {chan mailbox} { + set argd [punk::args::parse $args withid ::punk::imap4::DELETE] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + + punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT EXAMINE} DELETE $mailbox + } + + lappend PUNKARGS [list { + @id -id "::punk::imap4::RENAME" + @cmd -name "punk::imap4::RENAME" -help\ + "Rename a mailbox. + It is an error to attempt to rename from a mailbox + name that does not exist or to a mailbox name that + already exists. + Some servers will allow renaming INBOX - but with + special behaviour - moving all messages in INBOX + to a folder with the given name, leaving INBOX + empty - except that submailboxes of INBOX (if any) + are not moved." + @leaders -min 1 -max 1 + chan + @opts + @values -min 2 -max 2 + oldname + newname + }] + proc RENAME {args} { + set argd [punk::args::parse $args withid ::punk::imap4::SUBSCRIBE] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set oldname [dict get $values oldname] + set newname [dict get $values newname] + punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT EXAMINE} RENAME $oldname $newname + } + + lappend PUNKARGS [list { + @id -id "::punk::imap4::SUBSCRIBE" + @cmd -name "punk::imap4::SUBSCRIBE" -help\ + "Add the specified mailbox name to the server's set + of \"active\" or \"subscribed\" mailboxes as returned + by the LIST (SUBSCRIBED) command. + + Some servers may maintain a mailbox name in its + subscribed list even if the mailbox doesn't always + exist. e.g a system-alerts mailbox that is created + and removed as necessary. + " + @leaders -min 1 -max 1 + chan + @opts + @values -min 1 -max 1 + mailbox + }] + proc SUBSCRIBE {args} { + set argd [punk::args::parse $args withid ::punk::imap4::SUBSCRIBE] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT EXAMINE} SUBSCRIBE $mailbox + } + + lappend PUNKARGS [list { + @id -id "::punk::imap4::UNSUBSCRIBE" + @cmd -name "punk::imap4::UNSUBSCRIBE" -help\ + "Unsubscribe to a mailbox" + @leaders -min 1 -max 1 + chan + @opts + @values -min 1 -max 1 + mailbox + }] + proc UNSUBSCRIBE {args} { + set argd [punk::args::parse $args withid ::punk::imap4::UNSUBSCRIBE] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT EXAMINE} UNSUBSCRIBE $mailbox + } + + #TODO + proc IDLE {chan} { + if {[punk::imap4::proto::has_capability $chan IDLE]} { + punk::imap4::proto::simplecmd $chan -validstates {AUTH SELECT EXAMINE} IDLE + } else { + error "IMAP SERVER has NOT advertised the capability IDLE." + } + #todo - if we got a + - start a chan readable event handler on the channel + #what else can we get? immediate NO? a missing response is a definite possibility... + #no response until DONE is sent by client + return "" + } + proc IDLEDONE {chan} { + upvar ::punk::imap4::proto::info info + puts -nonewline $chan "DONE\r\n" + flush $chan + set info($chan,idle) {} + # - get response to initial IDLE command - REVIEW + set rtag [punk::imap4::lastrequesttag $chan] + if {[punk::imap4::proto::getresponse $chan $rtag]} { + return 1 + } + return 0 + } + + lappend PUNKARGS [list { + @id -id "::punk::imap4::FOLDERS" + @cmd -name "punk::imap4::FOLDERS" -help\ + "List of folders" + @leaders -min 1 -max 1 + chan + @opts + -ignorestate -type none + -inline -type none + @values -min 0 -max 2 + ref -default "" + mailboxpattern -default "*" + }] + # List of folders + proc FOLDERS {args} { + variable folderinfo + + set argd [punk::args::parse $args withid ::punk::imap4::FOLDERS] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set opt_inline [dict exists $received -inline] + set opt_ignorestate [dict exists $received -ignorestate] + set ref [dict get $values ref] + set mbox [dict get $values mailboxpattern] + + array unset folderinfo $chan,* + + if {$opt_ignorestate} { + set allowstates * + } else { + set allowstates {SELECT AUTH} + } + + set folderinfo($chan,match) [list $ref $mbox] + # parray folderinfo + #set rv [punk::imap4::proto::simplecmd $chan LIST $allowstates \"$ref\" \"$mbox\"] + if {[has_capability $chan SPECIAL-USE]} { + set rv [punk::imap4::proto::simplecmd $chan -validstates $allowstates LIST \"$ref\" \"$mbox\" RETURN {(SPECIAL-USE SUBSCRIBED)}] + } else { + set rv [punk::imap4::proto::simplecmd $chan -validstates $allowstates LIST \"$ref\" \"$mbox\" RETURN (SUBSCRIBED)] + } + if {!$opt_inline} { + return $rv + } + + set inlineresult {} + foreach f [folderinfo $chan flags] { + set lflags {} + foreach fl [lindex $f 1] { + #review - here we are converting things like {\HasNoChildren} to {hasnochildren} + #This may be desirable from a tcl script user's point of view - but may also + #be a surprise for those expecting the exact IMAP flags. todo? + if {[string is alnum [string index $fl 0]]} { + lappend lflags [string tolower $fl] + } else { + lappend lflags [string tolower [string range $fl 1 end]] + } + } + lappend inlineresult [list [lindex $f 0] $lflags] + } + return $inlineresult + } + + + # Search command. + proc SEARCH {chan args} { + if {![llength $args]} { + error "missing arguments. Usage: search chan arg ?arg ...?" + } + + punk::imap4::proto::requirestate $chan {SELECT EXAMINE} + set imapexpr [punk::imap4::proto::convert_search_expr $args] + punk::imap4::proto::multiline_prefix_command imapexpr "SEARCH" + punk::imap4::proto::multiline_request $chan $imapexpr + if {[punk::imap4::proto::getresponse $chan]} { + return 1 + } + return 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::imap4::debugchan + @cmd -name punk::imap4::debugchan -help\ + "Set or query the debug flag for an open + channel with a server. + This emits some basic information about the + client request and the final response from the + server to stdout for every command that + interacts with the server." + @leaders -min 1 -max 1 + chan + @values -min 0 -max 1 + onoff -type boolean -optional 1 + }] + proc debugchan {args} { + upvar ::punk::imap4::proto::coninfo coninfo + + set argd [punk::args::parse $args withid ::punk::imap4::debugchan] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + + if {![dict exists $received onoff]} { + #query + return [dict get $coninfo $chan debug] + } + dict set coninfo $chan debug [dict get $values onoff] + } + + lappend PUNKARGS [list { + @id -id ::punk::imap4::debugmode + @cmd -name punk::imap4::debugmode -help\ + "Debug mode. + This is a developer mode that provides a basic REPL + (Read Eval Print Loop) to interact more directly with the + server. + Every line entered is sent verbatim to the + server (after the automatic addition of the request identifier/tag). + + It's possible to execute Tcl commands by starting the line + with a forward slash." + @leaders -min 0 -max 0 + @values -min 1 -max 2 + chan -optional 0 -help\ + "existing channel for an open IMAP connection" + errormsg -default "None" + }] + + proc debugmode {chan {errormsg {None}}} { + variable debugmode 1 + variable debugchan $chan + variable version + variable folderinfo + #variable mboxinfo + #variable msginfo + upvar ::punk::imap4::proto::info info + upvar ::punk::imap4::proto::coninfo coninfo + + set welcometext [list \ + "------------------------ IMAP DEBUG MODE --------------------" \ + "server: [dict get $coninfo $chan hostname] port: [dict get $coninfo $chan port]" \ + "IMAP Debug mode usage: Every line typed will be sent" \ + "verbatim to the IMAP server prefixed with a unique IMAP tag." \ + "To execute Tcl commands prefix the line with a / character." \ + "The current debugged channel is returned by the \[me\] command." \ + "Type ! to exit debugmode" \ + "Type 'info' to see information about the connection" \ + "Type 'showlog ?requesttag|*?' to see the client/server log" \ + " (No arg required to show the last command, * to see full log)." \ + "Type 'help' to display this information" \ + "Last error: '$errormsg'" \ + "" \ + "IMAP library version: '$version'" \ + "" \ + ] + foreach l $welcometext { + puts $l + } + + set prev_chan_debug [dict get $coninfo $chan debug] + + dict set coninfo $chan debug 1 ;#ensure debug for this chan on while in debugmode + + punk::imap4::proto::debugmode_info $chan + set prev_stdin_conf [chan configure stdin] + + chan configure stdin -blocking 1 + # -inputmode not available in tcl 8.6 + catch { + chan configure -inputmode normal + } + + set last_request_tag * + try { + while 1 { + puts -nonewline "imap debug> " + flush stdout + gets stdin line + if {![string length $line]} continue + if {$line eq {!}} { + break + } + switch -glob -- $line { + info { + punk::imap4::proto::debugmode_info $chan + continue + } + help { + foreach l $welcometext { + if {$l eq ""} break + puts $l + } + continue + } + "showlog*" { + if {[regexp {^\s*showlog\s+(\S)\s*$} $line _ logtag]} { + puts [punk::imap4::showlog $chan $logtag] + } else { + puts [punk::imap4::showlog $chan $last_request_tag] + } + continue + } + } + if {[string index $line 0] eq {/}} { + catch {eval [string range $line 1 end]} result + #we may have called a function to make a request - sync our request tag + set last_request_tag [punk::imap4::lastrequesttag $chan] + puts $result + continue + } + # Let's send the request to imap server + set last_request_tag [punk::imap4::proto::request $chan $line] + if {[catch {punk::imap4::proto::getresponse $chan $last_request_tag} errormsg]} { + puts "--- ERROR ---\n$errormsg\n-------------\n" + } + } + } finally { + set debugmode 0 + dict set coninfo $chan debugmode $prev_chan_debug ;#restore channel debug flag + chan configure stdin -blocking [dict get $prev_stdin_conf -blocking] + if {[dict exists $prev_stdin_conf -inputmode]} { + #-inputmode not present in tcl 8.6 + chan configure stdin -inputmode [dict get $prev_stdin_conf -inputmode] + } + } + } + + + #review + proc me {} { + variable debugchan + set debugchan + } + + # Other stuff to do in random order... + # + # proc ::imap4::idle notify-command + # proc ::imap4::securestauth user pass + # proc ::imap4::store + # proc ::imap4::logout (need to clean both msg and mailbox info arrays) + + # Amend the flags of a message to be updated once CLOSE/EXPUNGE is initiated ;#obsolete? + #STORE of a flag should be imediately reflected in the server state. + #\Recent is imaprev1 only (deprecated) - but in any case, is read-only + #The UID SEARCH mechanism should now be used instead of looking for \Recent flag on the mailbox + #or the untagged response: * RECENT + #UID SEARCH UID > + #The \Recent flag may exist on messages - but is optional + lappend PUNKARGS [list { + @id -id ::punk::imap4::STORE + @cmd -name punk::imap4::STORE -help\ + "Alters data associated with a message (or messages) in the mailbox. + + The .SILENT suffix for the storetype arg indicates the client is not + requesting an untagged FETCH response indicating the new state of + the flags; however, even in it's presence, servers should send an + untagged FETCH response if an external change to the flags is + observed (e.g changed by another client/session) + " + @leaders -min 1 -max 1 + chan -optional 0 -help\ + "existing channel for an open IMAP connection" + @values -min 2 -max 3 + sequence-set -help\ + "A message sequence set such as: + 1:1 + 2:4 + *:3 + 1,3,5,7:9 + " + storetype -default +FLAGS -choicecolumns 1 -choiceprefix 0 -choices {+FLAGS +FLAGS.SILENT -FLAGS -FLAGS.SILENT FLAGS FLAGS.SILENT}\ + -choicelabels { + +FLAGS\ + "Add the supplied flagnames to the flags for the message. + The new value of the flags is returned as if a FETCH of + those flags was done." + +FLAGS.SILENT\ + "Equivalent to FLAGS, but without returning the new value." + -FLAGS\ + "Remove the supplied flagnames from the flags for the + message. The new value of the flags is returned as if a + FETCH of those flags was done." + -FLAGS.SILENT\ + "Equivalent to -FLAGS, but without returning a new value." + FLAGS\ + "REPLACE the flags for the message with the suplied + flagnames. The new value of the flags is returned as if + a FETCH of those flags was done." + FLAGS.SILENT\ + "Equivalent to FLAGS, but without returning a new value." + } -help\ + "The type of STORE operation to be performed on the upplied flagnames" + flagname -multiple 1 -choicecolumns 2 -choicerestricted 0 -choicegroups { + SystemFlags {{\Deleted} {\Flagged} {\Seen} {\Answered} {\Draft}} + Keywords9051 {{$MDNSent} {$Forwarded} {$Junk} {$NotJunk} {$Phishing}} + OtherKeywords {{$Important} {$Submitted} {$SubmitPending}} + Obsolete {{\Recent}} + }\ + -choicelabels { + {\Seen}\ + { Message has been read} + {\Answered}\ + { Message has been answered} + {\Flagged}\ + { Message is "flagged" for urgent/special attention} + {\Deleted}\ + { Message is "deleted" for removal by later EXPUNGE} + {\Draft}\ + { Message has not completed composition (marked as a + draft).} + {\Recent}\ + { This flag was in use in IMAP4rev1 and was deprecated + in RFC9051} + $Forwarded\ + " Message has been forwarded to another email address + by being embedded within, or attached to a new message. + An email client sets this keyword when it successfully + forwards the message to another email address. Typical + usage of this keyword is to show a different (or + additional) icon for a message that has been forwarded. + Once set, the flag SHOULD NOT be cleared." + $MDNSent\ + " Message Disposition Notification [RFC8098] was + generated and sent for this message. See [RFC3503] for + more details on how this keyword is used and for + requirements on clients and servers." + $Junk\ + " The user (or a delivery agent on behalf of the user) + may choose to mark a message as definitely containing + junk. The $Junk keyword can be used to mark, group, + or hide undesirable messages (and such messages might + be removed or deleted later)." + $NotJunk\ + " The user (or a delivery agent on behalf of the user) + may choose to mark a message as definitely not + containing junk. The $NotJunk keyword can be used to + mark, group, or show messages that the user wants to + see." + $Phishing\ + " The $Phishing keyword can be used by a delivery agent + to mark a message as highly likely to be a phishing + email. A message that's determined to be a phishing + email by the delivery agent should also be considered + junk email and have the appropriate junk filtering + applied, including setting the $Junk flag and placing + the message in the \Junk special-use mailbox if + available" + } -help\ + {Each supplied value is a system flag such as \Seen \Deleted etc or a + keyword/user-defined flag (a name not beginning with a backslash) + The items listed as Keywords9051 are mentioned in RFC9051 as SHOULD be supported + by servers. See also registered keywords: + https://www.iana.org/assignments/imap-jmap-keywords/imap-jmap-keywords.xhtml + } + }] + proc STORE {args} { + set argd [punk::args::parse $args withid ::punk::imap4::STORE] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set sequenceset [dict get $values sequence-set] + set storetype [dict get $values storetype] + set flagnames [dict get $values flagname] ;#multiple + + set ranges [split $sequenceset ,] + #parse each seq-range to give a chance to raise error + foreach range $ranges { + parse_seq-range $chan $range + } + + #review - do we need any client side validation? Duplicates only? + #What about presence of inconsistent flags $Junk $NotJunk? + #probably just best to let the server sort it out + #set validatedflags {} + #foreach fname $flagnames { + # if {[regexp {^\\+(.*?)$} $fname]} { + # #system flag - restrict? + # lappend validatedflags "\\$fname" + # } else { + # #user-defined flag - any name that does not start with a backslash + # lappend validatedflags $fname + # } + #} + set clitag [punk::imap4::proto::request $chan "STORE $sequenceset $storetype ([join $flagnames])"] + if {[punk::imap4::proto::getresponse $chan $clitag]} { + return 1 + } + return 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::imap4::LOGOUT + @cmd -name punk::imap4::LOGOUT -help\ + "End the connection cleanly. + + This disconnects from the server and reads the untagged BYE response + from the server. + It also tidies up client state associated with the channel." + @leaders -min 1 -max 1 + chan -optional 0 + @opts + @values -min 0 -max 0 + }] + proc LOGOUT {args} { + set argd [punk::args::parse $args withid ::punk::imap4::LOGOUT] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + + if {[punk::imap4::proto::simplecmd $chan LOGOUT]} { + # clean out info arrays + variable folderinfo + variable mboxinfo + variable msginfo + + upvar ::punk::imap4::proto::info info + upvar ::punk::imap4::proto::coninfo coninfo + + array unset folderinfo $chan,* + #array unset mboxinfo $chan,* + dict unset mboxinfo $chan + #array unset msginfo $chan,* + dict unset msginfo $chan + + array unset info $chan,* + dict unset $coninfo $chan + + return 1 + } + return 0 + } + + #Permanently removes all messages that have the \Deleted flag + #set from the currently selected mailbox. + proc EXPUNGE {chan} { + #Cannot call from EXAMINE state + if {[punk::imap4::proto::simplecmd $chan -validstates {SELECT} EXPUNGE]} { + return 1 + } + return 0 + } + + # copy : copy a message to a destination mailbox + lappend PUNKARGS [list { + @id -id ::punk::imap4::COPY + @cmd -name punk::imap4::COPY -help\ + "Copies the specified message(s) to the end + of the destination mailbox. + The server SHOULD preserve the flags and + internal date of the message(s) in the copy." + @leaders -min 1 -max 1 + chan + @values -min 2 -max 2 + sequence-set + mailbox + }] + proc COPY {args} { + set argd [punk::args::parse $args withid :punk::imap4::COPY] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set sequenceset [dict get $values sequence-set] + set mailbox [dict get $values mailbox] + if {[punk::imap4::proto::simplecmd $chan -validstates {SELECT EXAMINE} COPY $sequenceset $mailbox]} { + return 1 + } + return 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::imap4::APPEND + @cmd -name punk::imap4::APPEND -help\ + "EXPERIMENTAL - incomplete" + @leaders -min 2 -max 4 + chan + mailbox + #The API is a little clunky because the IMAP function has optional interim arguments between mailbox and message. + #We can only put flags after all leaders - which can make this function + #appear inconsistent with others where options always come after chan. + #This is a somewhat deliberate limitation of punk::args - it is intended to provide a simple understandable model + #covering most use-cases - not totally freeform mixes of options between other arguments - especially with optional + #non-flag arguments. (efficiency and complexity and unambiguity regarding values starting with - are important considerations) + #e.g "func a -opt1 o1 b? c? d e" is not supported. + #(optional non-flag args must be at end of leaders or values - and opts must be between those 2 sets.) + #so instead we will use the equiv of "func a b? c? -opt1 o1 d e" + flaglist -default {} -optional 1 -type list -help\ + {List of flags such as \Seen \Flagged} + datetime -default "" -optional 1 -type string + @opts + @values -min 1 -max 1 + message + }] + proc APPEND {args} { + set argd [punk::args::parse $args withid ::punk::imap4::APPEND] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $leaders mailbox] + set flaglist [dict get $leaders flaglist] + set datetime [dict get $leaders datetime] + set message [dict get $values message] + + #todo - send as single synchronizing literal after getting server's continuation (or non-synchronising literals) + + return 1 + #if {[punk::imap4::proto::simplecmd $chan -validstates {SELECT EXAMINE} APPEND $mailbox]} { + # return 1 + #} + #return 0 + } + + + #ascii art from RFC3501/RFC9051 + proc rfc_diagram {} { + punk::args::lib::tstr { + +----------------------+ + |connection established| + +----------------------+ + || + \/ + +--------------------------------------+ + | server greeting | + +--------------------------------------+ + || (1) || (2) || (3) + \/ || || + +-----------------+ || || + |Not Authenticated| || || + +-----------------+ || || + || (7) || (4) || || + || \/ \/ || + || +----------------+ || + || | Authenticated |<=++ || + || +----------------+ || || + || || (7) || (5) || (6) || + || || \/ || || + || || +--------+ || || + || || |Selected|==++ || + || || +--------+ || + || || || (7) || + \/ \/ \/ \/ + +--------------------------------------+ + | Logout | + +--------------------------------------+ + || + \/ + +-------------------------------+ + |both sides close the connection| + +-------------------------------+ + + (1) connection without pre-authentication + (OK greeting) + (2) pre-authenticated connection + (PREAUTH greeting) + (3) rejected connection (BYE greeting) + (4) successful LOGIN or AUTHENTICATE command + (5) successful SELECT or EXAMINE command + (6) CLOSE or UNSELECT command, unsolicited + CLOSED response code, or failed SELECT + or EXAMINE command + (7) LOGOUT command, server shutdown, or + connection closed + } + } + + #FROM RFC9051 + #"Session" refers to the sequence of client/server interaction from + #the time that a mailbox is selected (SELECT or EXAMINE command) until + #the time that selection ends (SELECT or EXAMINE of another mailbox, + #CLOSE command, UNSELECT command, or connection termination). + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::imap4 ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval punk::imap4::admin { + tcl::namespace::export {[a-zA-Z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "::punk::imap4::admin::GETQUOTA" + @cmd -name "punk::imap4::::admin::GETQUOTA" -help\ + "Get quota information" + @leaders -min 1 -max 1 + chan + @opts + @values -min 1 -max 1 + mailbox -help\ + "e.g user/account.test" + }] + proc GETQUOTA {args} { + set argd [punk::args::parse $args withid ::punk::imap4::admin::GETQUOTA] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + + punk::imap4::proto::simplecmd $chan GETQUOTA {AUTH SELECT} $mailbox + } + + lappend PUNKARGS [list { + @id -id "::punk::imap4::admin::SETQUOTARESOURCE" + @cmd -name "punk::imap4::admin::SETQUOTARESOURCE" -help\ + "Set quota for a resource" + @leaders -min 1 -max 1 + chan + @opts + -resource -default STORAGE -help\ + "This interface only allows setting of a single resource + at a time." + @values -min 2 -max 2 + mailbox -help\ + "e.g user/account.test" + quota -type integer -minsize 0 -help\ + "Number of 1024 Byte blocks + (KB)" + }] + proc SETQUOTARESOURCE {args} { + set argd [punk::args::parse $args withid ::punk::imap4::admin::SETQUOTARESOURCE] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + set resource [dict get $opts -resource] + set quota [dict get $values quota] + + punk::imap4::proto::simplecmd $chan SETQUOTA {AUTH SELECT} $mailbox "($resource $quota)" + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::imap4::lib { + tcl::namespace::export {[a-z]*} + tcl::namespace::path [tcl::namespace::parent] + + variable PUNKARGS + + #*** !doctools + #[subsection {Namespace punk::imap4::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 + #} + + #return 2 element list {address port} even if no port supplied. + #port value 0 if not supplied + proc parse_address_port {address_and_port} { + #must handle ipv6 & ipv4 addresses with and without port + #as ipv6 needs square brackets to handle possible port + # for symmetry we should support bracketed or unbracketed hostnames and ipv4 addresses too. + #e.g for localhost [::1]:143 + #e.g [1001:DF3:CF80::143] + set address_and_port [string trim $address_and_port] ;#tolerate surrounding whitespace + set csplit [split $address_and_port :] + switch -- [llength $csplit] { + 1 { + #portless address - could be bracketed/unbracketed ip4,ip6 or hostname + if {[string match {\[*\]} $address_and_port]} { + set address [string range $address_and_port 1 end-1] + set address [string trim $address] ;#tolerate whitespace in brackets + } else { + set address $address_and_port + } + set port 0 + } + 2 { + lassign $csplit addresspart port + #tolerate surrounding whitespace or whitespace around colon + set addresspart [string trim $addresspart] + set port [string trim $port] + if {[string match {\[*\]} $addresspart]} { + set address [string range $addresspart 1 end-1] + set address [string trim $address] + } else { + set address $addresspart + } + } + default { + #more than 1 colon - assume ipv6 - could be bracketed with or port + #or unbracketed without port + if {[regexp {\s*\[(.*)\]\s*(.*)} $address_and_port _match address tail]} { + if {[string match :* $tail]} { + set port [string range $tail 1 end] + set port [string trim $port] + if {$port eq ""} { + #we'll allow a trailing colon after square brackets as equivalent of unspecified port + set port 0 + } + } else { + set port 0 + } + } else { + #assume entire expression is unbracketed ipv6 with no port + set address $address_and_port + set port 0 + } + } + } + if {![string is integer -strict $port]} { + error "parse_address_port unable to determine address and port from $address_and_port - port not integer" + } + if {[regexp {\s} $address]} { + error "parse_address_port unable to determine address and port from $address_and_port - unexpected whitespace" + } + return [list $address $port] + } + + + ## Extract a quoted string + #proc imaptotcl_quoted {chan datavar} { + # upvar 1 $datavar data + # if {![regexp "\\s*?(\".*?\[^\\\\\]\"|\"\")\\s*?" $data => match]} { + # protoerror $chan "IMAP data format error: '$data'" + # } + # set data [string range $data [string length $match] end] + # return [string range $match 1 end-1] + #} + + + # imapwords - a nonregex based parsing of IMAP command/response structures + # see also imaptotcl_ functions for alternative mechanism + #consider what to do with partial lines due to literals: + # * METADATA Drafts ("/private/specialuse" {7} + #consider the following elements: + # BODY[] + # BODY[]<0.100> + # BINARY.PEEK[1]<100.200> + # we would categorise these as 'bare' initially - but switch to 'sectioned' at opening square bracket + # + #A654 FETCH 2:4 (FLAGS BODY[HEADER.FIELDS (DATE FROM)]) + # + #* OK [UIDVALIDITY 3857529045] UIDs valid + + #REVIEW + #consider also literal8? ~{} + #at the moment this will parse as 'bare' + + proc imapwords {line {maxwords 0}} { + #resulting dictionary to have number of words based on *toplevel* structure + # e.g BODY[HEADER.FIELDS (DATE FROM)] is a single word at the toplevel. + set len [string length $line] + set structure none ;#none|bare|sectioned|quoted|list|literal + set indq 0 ;#in double quotes + set squarenest 0 ;#in square brackets + set listnest 0 + #set inbracket 0 + #set inbrace 0 + set words [dict create] + set w -1 + set current "" + set inesc 0 + for {set i 0} {$i < $len} {incr i} { + set c [string index $line $i] + if {$inesc} { + if {$c eq "\\"} { + set inesc 0 + } + #treat char prefixed with a backslash as non-special e.g \( \) etc don't start/end lists, quoted sections etc + #we also encounter things such as \Sent for which the backslash is just a literal + set c "\\$c" + } else { + if {$c eq "\\"} { + set inesc 1 + continue + } + } + switch -- $structure { + none { + if {![string is space $c]} { + set openc "\{" ;#\} + set testc [string map [list $openc opencurly] $c] + #start of a new word + set indq 0 + switch -- $testc { + {"} { + incr w + set structure quoted + dict set words $w [dict create type quoted] + set indq 1 + } + {(} { + #) + incr w + set listnest 1 + set structure list + dict set words $w [dict create type list] + } + {[} { + #] + incr w + set squarenest 1 + set structure squarelist + dict set words $w [dict create type squarelist] + } + opencurly { + incr w + set structure literal + dict set words $w [dict create type literal] + } + default { + incr w + set structure bare + dict set words $w [dict create type bare] ;#this is our initial assumption - may be converted to 'sectioned' later + } + } + #our resulting list retains the exact syntax of elements - ie keep openers and closers + append current $c + } + } + bare { + #should usually be an imap ATOM - one or more non-special characters + + #we won't try to balance quotes if encountered in bare e.g xxx"y z" would become 2 bares - shouldn't exist anyway? + #assert not indq anyway + set indq 0 + if {![string is space $c]} { + if {$c eq "\["} { + #not actually an atom.. + set squarenest 1 + dict set words $w type sectioned + set structure sectioned + } + #\] + append current $c + } else { + #end of bare word + dict set words $w value $current + set current "" + set structure none + if {$maxwords == $w+1} { + break + } + } + } + squarelist { + #square bracketed substructures e.g + #[PERMANENTFLAGS ()] + #[CAPABILITY IMAP4rev1 LITERAL+ ...] + + #It's not known if the protocol or extensions have any subelements that are themselves squarelists + #but we need to count square brackets anyway. + #we don't check balance of sub lists - leave for a subsequent parse of this word's inner structure - REVIEW + if {$indq} { + #don't need to count squarenest or terminate on whitespace + if {$c eq "\""} { + set indq 0 + } + append current $c + } else { + #don't allow whitespace to terminate + if {$c eq "\["} { + #not known if this is necessary, but if we encounter nested square brackets - we'll assume balanced and try to handle + incr squarenest + append current $c + } elseif {$c eq "\]"} { + incr squarenest -1 + if {$squarenest == 0} { + #end of squarelist + dict set words $w value $current$c + set current "" + set structure none + if {$maxwords == $w+1} { + break + } + } + } elseif {$c eq "\""} { + set indq 1 + append current $c + } else { + append current $c + } + } + } + sectioned { + #whatever these sorts of things are: + # BODY[] + # BODY[]<0> + #The squarebracketed parts can contain substructures like squarelist - but we want to treat this whole thing + #as a word from a toplevel perspective. + # + if {$indq} { + #don't need to count squarenest or terminate on whitespace + if {$c eq "\""} { + set indq 0 + } + append current $c + } else { + if {$squarenest > 0} { + #don't allow whitespace to terminate + if {$c eq "\["} { + #not known if this is necessary, but if we encounter nested square brackets - we'll assume balanced and try to handle + incr squarenest + } elseif {$c eq "\]"} { + incr squarenest -1 + } elseif {$c eq "\""} { + set indq 1 + } + append current $c + } else { + #presumably at tail e.g BODY[]<0.100> + if {![string is space $c]} { + if {$c eq "\["} { + incr squarenest + } elseif {$c eq "\]"} { + incr squarenest -1 + } elseif {$c eq "\""} { + set indq 1 + } + append current $c + } else { + #end of sectioned + dict set words $w value $current + set current "" + set structure none + if {$maxwords == $w+1} { + break + } + } + } + } + } + quoted { + #assert indq 1 anyway + set indq 1 + if {$c eq "\""} { + set indq 0 + #end of quoted - we shouldn't have to handle "xxx"y - it will become the same as "xxx" y REVIEW + dict set words $w value $current$c + set current "" + set structure none + if {$maxwords == $w+1} { + break + } + } else { + append current $c + } + } + list { + #review + #we are not catering for certain unbalanced things like brackets in square bracketed sections: ([xxx(etc]) - should not be required + # this would represent a word that won't be completed at line end - at which point we can detect as an error + #we do cater for unbalanced brackets in quoted strings - as arbitrary strings seem more likely. + if {$indq} { + if {$c eq "\""} { + set indq 0 + } + append current $c + } else { + if {$c eq "("} { + incr listnest + append current $c + } elseif {$c eq ")"} { + incr listnest -1 + if {$listnest == 0} { + #end outer list + dict set words $w value $current$c + set current "" + set structure none + if {$maxwords == $w+1} { + break + } + } else { + append current $c + } + } elseif {$c eq "\""} { + set indq 1 + append current $c + } else { + append current $c + } + } + } + literal { + #we are only catering for basic {nnn} where we expect nnn to be an integer byte count + #or {nnn+} + #Presumably these should be in quoted strings if in mailbox names, searches etc? REVIEW + #\{ ;#editorfix + set rc "\}" + # + if {$c eq $rc} { + #end literal + dict set words $w value $current$c + set current "" + set structure none + if {$maxwords == $w+1} { + break + } + } else { + append current $c + } + } + } + set inesc 0 + } + set size [dict size $words] + if {$size} { + set lastindex [expr {$size -1}] + set lastitem [dict get $words $lastindex] + if {![dict exists $lastitem value]} { + #the word didn't complete + dict set words $lastindex value $current + set lasttype [dict get $lastitem type] + #only bare or sectioned require space to terminate - or autoterminate at end of line + if {$lasttype ni {bare sectioned}} { + #other type didn't terminate at end of line - mark as incomplete + dict set words $lastindex error INCOMPLETE + } + } + } + + #outer level structure. imapwords can be called again on each word that is of type list or squarelist. + #If a word is of type 'sectioned' it will need to be split into parts for parsing separately + #e.g BINARY.PEEK[]<> (bare,squarelist?,partial) + return $words + } + + #taking an existing words dict that may contain type = literal entries (value = {n}) + # and a list of the previously read literals + # stitch them together + proc imapwords_resolved {words literals} { + dict for {wordindex wordinfo} $words { + if {[dict get $wordinfo type] eq "literal"} { + set lit [dict get $wordinfo value] + set litinner [string range $lit 1 end-1] + #server does not send non-synchronizing literals e.g {123+} + set resolved_value [::lpop literals 0] + if {[punk::imap4::proto::is_imap_number64 $litinner] && [string length $resolved_value] == $litinner} { + dict set words $wordindex value $resolved_value + } else { + #protoerror $chan "IMAP: METADATA malformed response ($lit mismatch size of literal [string length $val]) '$line'" + } + + dict set words $wordindex type resolvedliteral + } + } + return $words ;#resolved words where type 'literal' has been replaced with 'resolvedliteral' + } + + #firstword_basic and secondword_basic don't handle IMAP structures such as lists etc + proc firstword_basic {line} { + if {[regexp -indices -start 0 {\S+} $line range]} { + return [string range $line {*}$range] + } else { + error "firstword regexp failed" ;#why? + } + } + proc secondword_basic {line} { + if {[regexp -indices -start 0 {\S+} $line range]} { + lassign $range s e + if {[regexp -indices -start $e+1 {\S+} $line range]} { + return [string range $line {*}$range] + } else { + error "secondword regexp failed" ;#why? + } + } else { + error "secondword regexp failed." ;#why? + } + } + proc firstword {line} { + set words [imapwords $line 1] + if {[dict size $words]} { + return [dict get $words 0 value] + } + return "" + } + proc secondword {line} { + set words [imapwords $line 2] + if {[dict size $words] > 1} { + return [dict get $words 1 value] + } + return "" + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::imap4::lib ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::imap4 { + tcl::namespace::export {[a-zA-Z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + + namespace eval argdoc { + #namespace for custom argument documentation + namespace import ::punk::args::helpers::* + + proc package_name {} { + return punk::imap4 + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package punk::imap4 + A fork from tcllib imap4 module + + imap4 - imap client-side tcl implementation of imap protocol + } \n] + } + proc get_topic_License {} { + return "X11" + } + proc get_topic_Version {} { + return "$::punk::imap4::version" + } + proc get_topic_Contributors {} { + set authors {{Salvatore Sanfilippo } {Nicola Hall } {Magnatune } {Julian Noble }} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_notes {} { + punk::args::lib::tstr -return string { + X11 license - is MIT with additional clause regarding use of contributor names. + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::imap4::about" + dict set overrides @cmd -name "punk::imap4::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::imap4 + }] \n] + dict set overrides topic -choices [list {*}[punk::imap4::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::imap4::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::imap4::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::imap4::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::imap4 ::punk::imap4::admin ::punk::imap4::proto +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::imap4 [tcl::namespace::eval punk::imap4 { + variable pkg punk::imap4 + variable version + set version 0.9.1 +}] + +################################################################################ +# Example and test +################################################################################ +if {[info script] eq $argv0} { + + #when running a tm module as an app - we should calculate the corresponding tm path + #based on info script and the namespace of the package being provided here + #and add that to the tm list if not already present. + #(auto-cater for any colocated dependencies) + puts "--[info script]--" + + punk::args::define { + @id -id ::punk::imap4::commandline + @cmd -name imap4::commandline -help\ + "Sample imap4 app to show info about chosen folder + and a few of its messages" + @leaders -min 0 -max 0 + @opts + -debug -type none + -security -default TLS/SSL -nocase 1 -choices {None STARTTLS TLS/SSL} + -port -default 0 -type integer -help\ + "port to connect to. + It is invalid to set this as well as a non-zero + port value specified as part of the server argument" + @values -min 3 -max 4 + server -help\ + "server or IP - may optionally include port + e.g + server.example.com:143 + 10.0.0.1:993 + [::1]:143 + " + user + pass + folder -optional 1 -default INBOX + } + set argd [punk::args::parse $argv withid ::punk::imap4::commandline] + lassign [dict values $argd] leaders opts values received + if {[dict exists $received -debug]} { + set debugflags "-debug 1" + } else { + set debugflags "-debug 0" + } + set opt_security [dict get $opts -security] + set opt_port [dict get $opts -port] + set server [dict get $values server] + lassign [punk::imap4::lib::parse_address_port $server] address addrport + if {$addrport !=0 && $opt_port != 0} { + puts stderr "Cannot specify port both in -port option as well as part of server argument" + puts stderr [punk::args::usage -scheme error ::punk::imap4::commandline] + return + } + if {$addrport != 0} { + set port $addrport + } else { + set port $opt_port ;#may still be zero + } + + set user [dict get $values user] + set pass [dict get $values pass] + set folder [dict get $values folder] + + # open and login ... + set imap [punk::imap4::CONNECT {*}$debugflags -security $opt_security $server $opt_port] + punk::imap4::AUTH_LOGIN $imap $user $pass + + punk::imap4::select $imap $folder + # Output all the information about that mailbox + foreach info [punk::imap4::mboxinfo $imap] { + puts "$info -> [punk::imap4::mboxinfo $imap $info]" + } + set num_mails [punk::imap4::mboxinfo $imap exists] + if {!$num_mails} { + puts "No mail in folder '$folder'" + } else { + set fields {from: to: subject: size} + # fetch 3 records (at most)) inline + set max [expr {$num_mails<=3?$num_mails:3}] + foreach rec [punk::imap4::FETCH $imap 1:$max -inline {*}$fields] { + puts -nonewline "#[incr idx])" + for {set j 0} {$j<[llength $fields]} {incr j} { + puts "\t[lindex $fields $j] [lindex $rec $j]" + } + } + + # Show all the information available about the message ID 1 + puts "Available info about message 1 => [punk::imap4::msginfo $imap 1]" + } + + # Use the capability stuff + puts "Capabilities: [punk::imap4::proto::has_capability $imap]" + puts "Is able to imap4rev1? [punk::imap4::proto::has_capability $imap imap4rev1]" + if {[dict get $::punk::imap4::coninfo $imap debug]} { + punk::imap4::debugmode $imap + } + + # Cleanup + punk::imap4::cleanup $imap +} +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.5.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.5.tm index a746058a..6b2dd8a9 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.5.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.5.tm @@ -174,6 +174,18 @@ tcl::namespace::eval punk::lib::check { set description "lsearch -stride with -subindices -inline -all and single index - incorrect results." return [dict create bug $bug bugref 5a1aaa201d description $description level major] } + proc has_tclbug_lseq_sign {} { + #https://core.tcl-lang.org/tcl/tktview/999b6966b2 + if {[catch {lseq 1 10}]} { + set bug 0 + } else { + set r1 [lseq 1 10 -9] + set r2 [lseq 1 10 -10] + set bug [expr {$r1 ne $r2}] + } + set description "lseq step sign not matching sequence direction - inconsistent results." + return [dict create bug $bug bugref 999b6966b2 description $description level minor] + } proc has_tclbug_list_quoting_emptyjoin {} { #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 @@ -827,23 +839,67 @@ namespace eval punk::lib { #tcl 8.7+ lseq significantly faster, especially for larger ranges #The internal rep can be an 'arithseries' with no string representation #support minimal set from to - proc range {from to} { - lseq $from $to + proc range {from to {by 1}} { + #note inconsistency with lseq 1 10 by -9 vs lseq 1 10 by -10 + #https://core.tcl-lang.org/tcl/tktview/999b6966b2 + lseq $from $to by $by } } else { #lseq accepts basic expressions e.g 4-2 for both arguments #e.g we can do lseq 0 [llength $list]-1 #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. - proc range {from to} { + #our range function doesn't support double like lseq does. (deliberate) review + proc range {from to {by ""}} { + if {$by eq "0"} { + #as per lseq, step (by) zero always gives no result + return [list] + } set to [offset_expr $to] set from [offset_expr $from] + if {$by ne ""} { + set by [offset_expr $by] + } + #assert $by is now empty string or an integer if {$to > $from} { - set count [expr {($to -$from) + 1}] - if {$from == 0} { - return [lsearch -all [lrepeat $count 0] *] - } else { - incr from -1 - return [lmap v [lrepeat $count 0] {incr from}] + switch -- $by { + "" - 1 { + set count [expr {($to -$from) + 1}] + if {$from == 0} { + return [lsearch -all [lrepeat $count 0] *] + } else { + incr from -1 + return [lmap v [lrepeat $count 0] {incr from}] + } + } + default { + set count [expr {($to - $from + $by) / $by}] + if {$count <= 0} { + #return [list] + #https://core.tcl-lang.org/tcl/tktview/999b6966b2 + return [list $from] ;#review + } + set result [list] + for {set i $from} {$i <= $to} {incr i $by} { + lappend result $i + } + return $result + + #if we don't have lseq, we probably don't have lsearch -stride, which would make things simpler. + #set count [expr {($to -$from) + 1}] + #if {$from == 0} { + # set fullrange [lsearch -all [lrepeat $count 0] *] + #} else { + # incr from -1 + # set fullrange [lmap v [lrepeat $count 0] {incr from}] + #} + #set result [list] + #for {set i 0} {$i < $count} {incr i} { + # if {$i % $by == 0} { + # lappend result [lindex $fullrange $i] + # } + #} + #return $result + } } #slower methods. #2) @@ -858,13 +914,28 @@ namespace eval punk::lib { #} #return $L } elseif {$from > $to} { - set count [expr {$from - $to} + 1] - #1) - if {$to == 0} { - return [lreverse [lsearch -all [lrepeat $count 0] *]] - } else { - incr from - return [lmap v [lrepeat $count 0] {incr from -1}] + switch -- $by { + "" - -1 { + set count [expr {$from - $to} + 1] + if {$to == 0} { + return [lreverse [lsearch -all [lrepeat $count 0] *]] + } else { + incr from + return [lmap v [lrepeat $count 0] {incr from -1}] + } + } + default { + set count [expr {($to - $from + $by) / $by}] + if {$count <= 0} { + #return [list] + return [list $from] ;#review + } + set result [list] + for {set i $from} {$i >= $to} {incr i $by} { + lappend result $i + } + return $result + } } #2) @@ -2468,7 +2539,7 @@ namespace eval punk::lib { #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} { - set expression [tcl::string::map {_ {}} $expression] + set expression [tcl::string::map {_ {}} $expression] ;#review - this is for 8.6 to understand underscored ints if {[tcl::string::is integer -strict $expression]} { return [expr {$expression}] } @@ -2531,22 +2602,35 @@ namespace eval punk::lib { if {$rposn >= 0} { set sepsize 2 set step 1 - } else { + #review - whitespace between ints? + lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + } elseif {[string first . $r] >= 0} { + set stripped [string map {. ""} $r] + if {[tcl::string::length $stripped] != [tcl::string::length $r]-2} { + #if one dot exists - must be exactly 2 dots in total - possibly separated by positive/negative int (not zero) + return 0 + } + #assert - we have exactly 2 dots separated by something. #check for .n. 'stepped' range set fdot [string first . $r] set ldot [string last . $r] set step [string range $r $fdot+1 $ldot-1] #todo - allow basic mathops for step: 2+1 2+-1 etc same as tcl lindex, lseq - if {![string is integer -strict $step]} { - } - } + #1.0.10 should be valid but behave similarly to lseq 1 0 by 0 ie returns nothing - if {$rposn >= 0} { - lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + #1.end.10 or similar shouldn't be valid - but we need to allow other basic index expressions. + if {[string match *end* $step] || [catch {lindex {} $step}]} { + return 0 + } + #if {![string is integer -strict $step] || $step == 0} { + # return 0 + #} + lappend validateindices {*}[string range $r 0 $fdot-1] {*}[string range $r $ldot+1 end] } else { #'range' is just an index set validateindices [list $r] } + foreach v $validateindices { if {$v eq "" || $v eq "end"} {continue} if {[string is integer -strict $v]} {continue} @@ -2558,6 +2642,7 @@ namespace eval punk::lib { return 1 } #review - compare to IMAP4 methods of specifying ranges? + #TODO add tests to test::punk::lib indexset_resolve is a little tricky punk::args::define { @id -id ::punk::lib::indexset_resolve @cmd -name punk::lib::indexset_resolve\ @@ -2568,13 +2653,44 @@ namespace eval punk::lib { e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9 An indexset consists of a comma delimited list of indexes or index-ranges. - Ranges must be specified with .. as the separator, with an empty value at either side of the - separator representing beginning and end of the index range respectively. + Ranges must be specified with a range-indicator such as .. as the separator, with an empty value at + either side of the separator representing beginning and end of the index range respectively. + The range-separator can be of the form .x. where x is an integer or basic expression + (single +/- operation) that indicates the step value to use. This is equivalent to the 'by' value + in the tcl9 lseq command. + + When the start index is lower than the end, the step value defaults to 1. + ie indexset_resolve 0..7 is equivalent to indexset_resolve 0.1.7 + When the start index is higher than the end, the step value defaults to -1. + ie indexset_resolve 7..0 is equivalent to indexset_resolve 0.-1.7 + + If start and end are ommitted, increasing order is assumed if the step isn't specified. + eg + .. represents the range from the base to the end + .-1. would represent end to base with step -1 + + If start is omitted and only the end is supplied: + The default step is 1 indicating ascension and the missing end is equivalent to 'end' + indexset_resolve 5 2.. + -> 2 3 4 + The default end is the base if the step is negative + indexset_resolve 5 2.-1. + -> 2 1 0 + If end is omitted and onlthe start is supplied: + The default step is 1 indicating ascension and the missing start is equivalent to the base. + indexset_resolve 5 ..2 + -> 0 1 2 + The default start is 'end' if the step is negative + indexset_resolve 5 .-1.2 + -> 4 3 2 + + + Like the tcl9 lseq command - a step (by) value of zero produces no results. The indexes are 0-based by default, but the base can be specified. indexset_resolve 7 .. -> 0 1 2 3 4 5 6 - indexset_resolve 7 .. -3 + indexset_resolve -base -3 7 .. -> -3 -2 -1 0 1 2 3 Whitespace is ignored. @@ -2599,10 +2715,9 @@ namespace eval punk::lib { output the first 3 indices, and the last index. end-1..0 output the indexes in reverse order from 2nd last item to first item." - @values -min 2 -max 3 - numitems -type integer - indexset -type indexset -help "comma delimited specification for indices to return" - base -type integer -default 0 -help\ + @leaders -min 0 -max 0 + @opts + -base -type integer -prefix 1 -default 0 -help\ "This is the starting index. It can be positive, negative or zero. This affects the start and end calculations, limiting what indices will be returned. @@ -2613,73 +2728,175 @@ namespace eval punk::lib { For base 1, index 0 is considered to be below the range. ie - indexset_resolve 10 0..3 1 + indexset_resolve -base 1 10 0..3 -> 1 2 3 - indexset_resolve 10 0..3 0 + indexset_resolve -base 0 10 0..3 -> 0 1 2 3 - It does not *convert* integers within the range. + It does not *convert* indexes within the range. - indexset_resolve 10 5 1 + indexset_resolve -base 1 10 5 -> 5 - indexset_resolve 10 5 0 + indexset_resolve -base 0 10 5 -> 5 - ie if you ask for a 1 based indexset the integers that are within the - range will come out the same, so the result needs to be treated as a - 1-based set of indices when performing further operations. + ie if you ask for a 1-based resolution of an indexset the integers that are within + the range will come out the same, so the result needs to be treated as a 1-based + set of indices when performing further operations. " + @values -min 2 -max 3 + numitems -type integer + indexset -type indexset -help "comma delimited specification for indices to return" } - proc indexset_resolve {numitems indexset {base 0}} { + + #limit punk::args parsing to unhappy paths where possible + proc indexset_resolve {args} { + # -------------------------------------------------- + # Manual parsing of happy path args instead of using punk::args::parse $args withid ::punk::lib::indexset_resolve + # This is because indexset_resolve is *somewhat* low level, has only a few args, and we don't want any overhead. + # for the unhappy path - the punk::args::parse is fine to generate the usage/error information. + # -------------------------------------------------- + if {[llength $args] < 2} { + punk::args::resolve $args withid ::punk::lib::indexset_resolve + } + set indexset [lindex $args end] + set numitems [lindex $args end-1] if {![string is integer -strict $numitems] || ![is_indexset $indexset]} { #use parser on unhappy path only set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] } + #assert we have 2 or more args + set base 0 ;#default + if {[llength $args] > 2} { + #if more than just numitems and indexset - we expect only -base ie 4 args in total + if {[llength $args] != 4} { + set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] + } + set optname [lindex $args 0] + set optval [lindex $args 1] + set fulloptname [tcl::prefix::match -error "" -base $optname] + if {$fulloptname ne "-base" || ![string is integer -strict $optval]} { + set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] + } + set base $optval + } + # -------------------------------------------------- + + set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace set index_list [list] ;#list of actual indexes within the range set iparts [split $indexset ,] set based_max [expr {$numitems -1 + $base}] + #we already did is_indexset check above, so we can make assumptions about well-formedness of each part foreach ipart $iparts { set ipart [string trim $ipart] - set rposn [string first .. $ipart] + #we need to cater for n..m as well as n.s.m where s is 'step' + set rposn [string first . $ipart] if {$rposn>=0} { - #range - lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb - set rawa [string trim $rawa] - set rawb [string trim $rawb] - if {$rawa eq ""} {set rawa $base} - set a [punk::lib::lindex_resolve $numitems $rawa $base] - if {$a == -Inf} { - #(was -3) - #undershot - leave negative - } elseif {$a == Inf} { - #overshot - set a [expr {$based_max + 1}] ;#put it outside the range on the upper side + #if we found one dot - there must be exactly 2 dots in the ipart, separated by nothing, or a basic integer-expression + set rposn2 [string last . $ipart] + if {$rposn2 == $rposn+1} { + #.. + set step "default" ;#could be 1 or -1 + } else { + set step [tcl::string::range $ipart $rposn+1 $rposn2-1] } - #review - a may be -Inf + lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn2+1] rawa _ rawb - if {$rawb eq ""} { - if {$a > $based_max} { - set rawb $a ;#make sure .. doesn't return last item - should return nothing + set rawa [string trim $rawa] + set rawb [string trim $rawb] + if {$rawa eq "" && $rawb eq ""} { + if {$step eq "default"} { + set step 1 ;#default ascending when no start and no end + } + if {$step < 0} { + set rawa end + set rawb $base } else { + set rawa $base set rawb end } - } - set b [punk::lib::lindex_resolve $numitems $rawb $base] - if {$b == -Inf} { - #undershot - leave negative - } elseif {$b == Inf} { - #set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side - set b [expr {$based_max + 1}] ;#overshot - put it outside the range on the upper side + #if neither start nor end specified - we won't get out of range results from lindex_resolve + set a [punk::lib::lindex_resolve $numitems $rawa $base] + set b [punk::lib::lindex_resolve $numitems $rawb $base] + } else { + if {$rawa eq ""} { + if {$step eq "default"} { + #when start not specified, but end is - default direction always ascending + #(even if end is base or below range) + set step 1 + } + if {$step < 0} { + set rawa end + } else { + set rawa $base + } + } + set a [punk::lib::lindex_resolve $numitems $rawa $base] + if {$a == -Inf} { + #undershot - leave negative + } elseif {$a == Inf} { + #overshot + set a [expr {$based_max + 1}] ;#put it outside the range on the upper side + } + #review - a may be -Inf + + if {$rawb eq ""} { + if {$step eq "default"} { + set step 1 + } + if {$step < 0} { + if {$a < $base} { + #make sure both + #mathfunc::isinf is tcl9+ + if {[catch { + if {[::tcl::mathfunc::isinf $a]} { + set a [expr {$base -1}] + } + }]} { + if {[string match -nocase *inf* $a]} { + set a [expr {$base -1}] + } + } + set rawb $a + } else { + set rawb $base + } + } else { + if {$a > $based_max} { + set rawb $a ;#make sure .. doesn't return last item - should return nothing + } else { + set rawb end + } + } + } + set b [punk::lib::lindex_resolve $numitems $rawb $base] + if {$b == -Inf} { + #undershot - leave negative + } elseif {$b == Inf} { + #set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side + set b [expr {$based_max + 1}] ;#overshot - put it outside the range on the upper side + } } #JJJ #e.g make sure .. doesn't return last item - should return nothing as both are above the range. if {$a >= $base && $a <= $based_max && $b >=$base && $b <= $based_max} { - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + #assert a & b are integers within the range + if {$step eq "default"} { + #unspecified step - base direction on order of a & b + if {$a <= $b} { + set step 1 + } else { + set step -1 + } + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } else { if {$a >= $base && $a <= $based_max} { #only a is in the range @@ -2688,27 +2905,57 @@ namespace eval punk::lib { } else { set b $based_max } - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + if {$step eq "default"} { + if {$a <= $b} { + set step 1 + } else { + set step -1 + } + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } elseif {$b >=$base && $b <= $based_max} { #only b is in the range - if {$a < $base} { - set a $base + if {$step eq "default"} { + if {$a <= $b} { + set step 1 + } else { + set step -1 + } + } + if {$step < 0} { + if {$a < $base} { + #negative step from below - doesn't matter if b is in range - recast both to an int below $base + #(a may be -Inf) + set a [expr {$base -1}] + set b $a + set step 0 ;#we should return nothing + } } else { - set a $based_max + if {$a < $base} { + set a $base + } else { + set a $based_max + } } - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } else { #both outside the range if {$a < $base && $b > $base} { #spans the range in forward order set a $base set b $based_max - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + if {$step eq "default"} { + set step 1 + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } elseif {$a > $base && $b < $base} { #spans the range in reverse order set a $based_max set b $base - lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. + if {$step eq "default"} { + set step -1 + } + lappend index_list {*}[punk::lib::range $a $b $step] ;#required for tcl8.6, on tcl9 this will call lseq internally. } #both outside of range on same side } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm index fea6b146..d7eaf639 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm @@ -62,7 +62,7 @@ package require Tcl 8.6- -tcl::namespace::eval punk::libunknown { +tcl::namespace::eval ::punk::libunknown { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -1576,7 +1576,7 @@ tcl::namespace::eval punk::libunknown { } # == === === === === === === === === === === === === === === -namespace eval punk::libunknown { +namespace eval ::punk::libunknown { #for 8.6 compat if {"::ledit" ni [info commands ::ledit]} { #maint: taken from punk::lib @@ -1702,7 +1702,7 @@ namespace eval punk::libunknown { } } -tcl::namespace::eval punk::libunknown::lib { +tcl::namespace::eval ::punk::libunknown::lib { #A version of textutil::string::longestCommonPrefixList #(also as ::punk::lib::longestCommonPrefixList) @@ -1788,7 +1788,7 @@ namespace eval ::punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready -package provide punk::libunknown [tcl::namespace::eval punk::libunknown { +package provide punk::libunknown [tcl::namespace::eval ::punk::libunknown { variable pkg punk::libunknown variable version set version 0.1 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm new file mode 100644 index 00000000..ae61d932 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm @@ -0,0 +1,3271 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::netbox 0.1.1 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::netbox 0 0.1.1] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::netbox] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::netbox +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::netbox +#[list_begin itemized] + +package require Tcl 8.6- +package require http +package require rest +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {http}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::netbox::class { + #*** !doctools + #[subsection {Namespace punk::netbox::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval punk::netbox {} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::netbox::system { + #*** !doctools + #[subsection {Namespace punk::netbox::system}] + #[para] Internal functions that are not part of the API + + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + + punk::args::define { + @id -id ::punk::netbox::system::make_rest_func + @leaders -min 2 -max 2 + commandname -help\ + "Fully qualified commandname. + There must be an existing punk::args definition with @id + directive -id matching the name" + endpoint -help\ + "The subpath to be appended to the base url. + e.g api/ipam/ip-addresses/ + api/ipam/ip-addresses/{id}/" + -verb -default get -choices {get post patch head put delete} + -body -default optional -choicecolumns 2 -choices {none optional required mime_multipart}\ + -choicelabels { + none\ + " The call has no request body, + none must be supplied." + optional\ + " A request body can be supplied, + but is not required" + required\ + " A request body must be supplied." + mime_multipart\ + " A request body must be supplied + and will be interpreted as each + argument representing one part of + a mime/multipart document. Arguments + must be lists containing 2 elements, + a list of header keys and values, + and the mime part body, in this order." + } + } + + #A somewhat sanitized config for outputting to stderr etc + #Obscure at least full Authorization Token + #todo - other headers? + proc obscured_config {cfg} { + set sanconfig $cfg + if {[dict exists $cfg headers]} { + set hdrs [dict get $cfg headers] + if {[dict exists $hdrs Authorization]} { + set auth [dict get $hdrs Authorization] + if {[dict exists $auth Token]} { + dict set auth Token "[string range [dict get $auth Token] 0 5]..." + dict set hdrs Authorization $auth + dict set sanconfig headers $hdrs + } + } + } + return $sanconfig + } + variable call_data + array unset call_data + + proc make_rest_func {args} { + set argd [punk::args::parse $args withid ::punk::netbox::system::make_rest_func] + lassign [dict values $argd] leaders opts values received + + set commandname [dict get $leaders commandname] + set endpoint [dict get $leaders endpoint] + set verb [dict get $opts -verb] + set body [dict get $opts -body] + + set custom [dict create\ + %commandname% $commandname\ + %endpoint% $endpoint\ + %verb% $verb\ + %body% $body\ + %showpagedict% {!@@results @@results/@*/@*.@*}\ + %showpagedict2% {@@results/@*/@*.@* !@@results}\ + %showdict% {*}\ + %showdict2% {*/*}\ + %showlistofdicts% {@*/@*.@*}\ + ] + if {$commandname eq "::punk::netbox::status"} { + #we get duplicate django-version for %showdict% - todo - something. + dict set custom %showdict% {@@django-version @@installed-apps/@*.@* !@@installed-apps} + dict set custom %showdict2% {@@installed-apps/@*.@* !@@installed-apps} + } + + set procbody [string map $custom { + set argd [punk::args::parse $args withid %commandname%] + lassign [dict values $argd] leaders opts values received solos multis + set apicontextid [dict get $leaders apicontextid] + if {[dict exists $received -RETURN]} { + set returntype [dict get $opts -RETURN] + } else { + if {[dict exists $opts -RETURN]} { + #not received - but has default + set returntype [dict get $opts -RETURN] + } else { + #fallback if -RETURN was defined without a default or was omitted + set returntype dict + } + } + + set FORCE 1 + if {[dict exists $opts -FORCE]} { + set FORCE [dict get $opts -FORCE] + } + + set query [list] ;#use list not dict - allows repeated params + dict for {k val} $opts { + switch -- $k { + -CUSTOM_PARAM { + #'-multiple true' + foreach kv $val { + lassign $kv paramname value + lappend query $paramname $value + } + } + -RETURN { + #ignore - already handled + } + default { + if {[string match *_FILTER $k]} { + #all _FILTER methods are '-multiple true' - so are present in $opts as a single key with a value that is a list + #e.g -X_Y_FILTER "blah" + set parts [split $k _] + set name1 [string range [string tolower [lindex $parts 0]] 1 end] ;#strip leading dash off first part + set nametail [string tolower [lrange $parts 1 end-1]] + set paramname [join [list $name1 {*}$nametail] _] + foreach fv $val { + lassign $fv filter value ;#filter is n,gte,lte etc + lappend query ${paramname}__$filter $value + } + } else { + set paramname [string range $k 1 end] + if {$paramname in $multis} { + foreach v $val { + lappend query $paramname $v + } + } else { + lappend query $paramname $val + } + } + } + } + + } + set body %body% + switch -- $body { + required { + set requestbody [dict get $values body] + } + optional { + if {[dict exists $received body]} { + set requestbody [dict get $values body] + } else { + set requestbody "" + } + } + } + upvar ::punk::netbox::contexts contexts + if {![dict exists $contexts $apicontextid]} { + error "specified contextid '$apicontextid' not found" + } + set config [dict create\ + format json\ + result json\ + ] + #rest api documentation is unclear on 'result' field + #note our default: result json + #this actually converts the json to a dict + + + dict set config headers [list Authorization [list Token [dict get $contexts $apicontextid token value]]] + if {$returntype in "json jsondump"} { + #if we set result json - we get a dict instead of json :/ + #The 'result' key seems to tell ::rest what post-processor to use to translate it *from* that to a tcl dict (or in xml case a nested list) + #sort of.. + #xml - takes xml produces a list + #json - takes json produces a dict + #discard - 'return -code ok' + #auto - *basic* detect xml or json and do as above + #tdom - takes xml - produces a tdom documentElement + #raw - just returns the data + dict set config result raw + } + if {$body in {required optional}} { + #content type for the request data + dict set config headers content-type "application/json" + } + + set url [dict get $contexts $apicontextid url value] + set endpoint "%endpoint%" + if {[string first {{id}} $endpoint] != -1} { + set id [dict get $values id] + set endpoint [string map [list {{id}} $id] $endpoint] + } + + #??? + dict set config error-body false + + #todo - only show if debug (and obscure Authorization Token) + set sanconfig [punk::netbox::system::obscured_config $config] + puts stderr "url:${url}$endpoint query:'$query' verb:%verb% config:'$sanconfig'" + if {$FORCE} { + #FORCE is true for most operations (and no -FORCE option even available) but the option exists and defaults to false for specifically unsafe + #e.g delete operations on entire endpoints + if {$body in {required optional}} { + set result [::rest::%verb% ${url}$endpoint $query $config $requestbody] + } else { + set result [::rest::%verb% ${url}$endpoint $query $config] + } + #puts "-----------" + #puts $result + #puts "-----------" + + } else { + puts stderr "%commandname% not called because -FORCE is false" + set sanconfig [punk::netbox::system::obscured_config $config] + puts "url:${url}$endpoint query:'$query' verb:%verb% config:'$sanconfig'" + return + } + switch -exact -- $returntype { + showpagedict { + #return [punk::lib::showdict $result !@@results @@results/@*/@*.@*] + return [punk::lib::showdict $result %showpagedict%] + } + showpagedict2 { + #return [punk::lib::showdict $result @@results/@*/@*.@* !@@results] + return [punk::lib::showdict $result %showpagedict2%] + } + showdict { + return [punk::lib::showdict $result %showdict%] + } + showdict2 { + return [punk::lib::showdict $result %showdict2%] + } + showlist { + return [punk::lib::showdict -roottype list $result] + } + showlistofdicts { + return [punk::lib::showdict $result %showlistofdicts%] + } + jsondump { + package require huddle::json + #pretty-print via huddle (inefficient review) + set h [huddle::json::json2huddle parse $result] + return [huddle::jsondump $h] + } + linelist { + set ret "" + foreach r $result { + append ret $r \n + } + return $ret + } + default { + #plain result: (list or dict) or json - the counterintuitive 'result' field set to raw above sets the rest resulting format to the original json + return $result + } + } + }] + proc $commandname {args} $procbody + } + #experiment + variable callid + set callid 0 + proc make_rest_func_async {args} { + set argd [punk::args::parse $args withid ::punk::netbox::system::make_rest_func] + lassign [dict values $argd] leaders opts values received + + set commandname [dict get $leaders commandname] + set endpoint [dict get $leaders endpoint] + set verb [dict get $opts -verb] + set bodycontrol [dict get $opts -body] + + set custom [dict create\ + %commandname% $commandname\ + %endpoint% $endpoint\ + %verb% $verb\ + %bodycontrol% $bodycontrol\ + %showpagedict% {!@@results @@results/@*/@*.@*}\ + %showpagedict2% {@@results/@*/@*.@* !@@results}\ + %showdict% {*}\ + %showdict2% {*/*}\ + %showlistofdicts% {@*/@*.@*}\ + ] + + + set procbody [string map $custom { + upvar ::punk::netbox::system::callid callid + incr callid + + set argd [punk::args::parse $args withid %commandname%] + lassign [dict values $argd] leaders opts values received solos multis + set apicontextid [dict get $leaders apicontextid] + if {[dict exists $received -RETURN]} { + set returntype [dict get $opts -RETURN] + } else { + if {[dict exists $opts -RETURN]} { + #not received - but has default + set returntype [dict get $opts -RETURN] + } else { + #fallback if -RETURN was defined without a default or was omitted + set returntype dict + } + } + + #-ASYNC is of -type none - solo flag + if {[dict exists $received -ASYNC]} { + set async true + } else { + set async false + } + + set FORCE 1 + if {[dict exists $opts -FORCE]} { + set FORCE [dict get $opts -FORCE] + } + + set query [list] ;#use list not dict - allows repeated params + dict for {k val} $opts { + switch -- $k { + -CUSTOM_PARAM { + #'-multiple true' + foreach kv $val { + lassign $kv paramname value + lappend query $paramname $value + } + } + -RETURN - -ASYNC - -FORCE { + #ignore - not options for endoint - already handled + } + default { + if {[string match *_FILTER $k]} { + #all _FILTER methods are '-multiple true' - so are present in $opts as a single key with a value that is a list + #e.g -X_Y_FILTER "blah" + set parts [split $k _] + set name1 [string range [string tolower [lindex $parts 0]] 1 end] ;#strip leading dash off first part + set nametail [string tolower [lrange $parts 1 end-1]] + set paramname [join [list $name1 {*}$nametail] _] + foreach fv $val { + lassign $fv filter value ;#filter is n,gte,lte etc + lappend query ${paramname}__$filter $value + } + } else { + set paramname [string range $k 1 end] + if {$k in $multis} { + foreach v $val { + lappend query $paramname $v + } + } else { + lappend query $paramname $val + } + } + } + } + + } + upvar ::punk::netbox::contexts contexts + if {![dict exists $contexts $apicontextid]} { + error "specified contextid '$apicontextid' not found" + } + + #rest api documentation is unclear on 'result' field + #note our default: result json + #this actually converts the json to a dict + + set config [dict create format json result json] + + dict set config headers [list Authorization [list Token [dict get $contexts $apicontextid token value]]] + set bodycontrol %bodycontrol% + switch -- $bodycontrol { + required { + set requestbody [dict get $values body] + #content type for the request data + dict set config headers content-type "application/json" + } + optional { + if {[dict exists $received body]} { + set requestbody [dict get $values body] + dict set config headers content-type "application/json" + } else { + set requestbody "" + } + } + default { + set requestbody "" + } + } + + + + set url [dict get $contexts $apicontextid url value] + set endpoint "%endpoint%" + if {[string first {{id}} $endpoint] != -1} { + set id [dict get $values id] + set endpoint [string map [list {{id}} $id] $endpoint] + } + append url $endpoint + + #??? + dict set config error-body false + + #todo - only show if debug (and obscure Authorization Token) + set sanconfig [punk::netbox::system::obscured_config $config] + puts stderr "url:$url query:'$query' verb:%verb% config:'$sanconfig'" + if {$FORCE} { + set thisproc [dict get [info frame 0] proc] + #FORCE is true for most operations (and no -FORCE option even available) but the option exists and defaults to false for specifically unsafe + #e.g delete operations on entire endpoints + + #---------------------------------------- + #from rest make_interface generated func: + set headers {} + dict for {key val} [dict get $config headers] {lappend headers $key [::rest::substitute $val query]} + set query [::http::formatQuery {*}$query] + #---------------------------------------- + set error_body true + + dict set config method %verb% ;#rest::_call does an upvar on config array + dict set config body $bodycontrol ;#this is required|optional not the requestbody data itself + #dict set config timeout ??? ;#todo -TIMEOUT flag? + + #============================================================================ + #rest::_call is just a small wrapper over http:: methods + #if {$bodycontrol in {required optional}} { + # #set result [::rest::%verb% ${url}$endpoint $query $config $requestbody] + # set httptok [::rest::_call [list ::punk::netbox::system::rest_call_complete $thisproc,$callid] $headers $url $query $requestbody $error_body] + #} else { + # #set result [::rest::%verb% ${url}$endpoint $query $config] + # set httptok [::rest::_call [list ::punk::netbox::system::rest_call_complete $thisproc,$callid] $headers $url $query "" $error_body] + #} + set method [string toupper %verb%] + + if {[string match no* $bodycontrol]} { + #never put the query in the body if the user said no body + } else { + if {![dict exists $received body] && $bodycontrol eq "required"} { + #our make_rest_func_async args say we need a body - but our punk::args validation didn't require it + #review + set requestbody $query + set query {} + } + } + + if {$query != ""} {append url ?$query} + #configure options to the http::geturl command + set opts [list] + lappend opts -method $method + if {[dict exists $headers content-type]} { + lappend opts -type [dict get $headers content-type] + set headers [dict remove $headers content-type] + } + if {$requestbody != ""} { + #-query arg for http::geturl causes it to do a POST with the value as the request payload. + lappend opts -query $requestbody + } + lappend opts -command [list ::punk::netbox::system::http_call_complete $thisproc $callid] + #if {[dict exists $config timeout]} { + # lappend opts -timeout [dict get $config timeout] + #} + set httptok [http::geturl $url -headers $headers {*}$opts] + #============================================================================ + + + + + #puts "tok: $httptok" + #puts "-----------" + #puts $result + #puts "-----------" + + upvar ::punk::netbox::system::call_data call_data + set call_data($thisproc,$callid,httptoken) $httptok + set call_data($thisproc,$callid,command) $thisproc + set call_data($thisproc,$callid,returntype) $returntype + set call_data($thisproc,$callid,config) $config + #todo - the actual async part - solo flag -ASYNC ? + if {$async} { + return $thisproc,$callid + } + #we need to then provide a $thisproc,$callid token to the caller and a retrieval/cleanup proc + http::wait $httptok + + return [punk::netbox::get_result $thisproc,$callid] + + } else { + puts stderr "%commandname% not called because -FORCE is false" + set sanconfig [punk::netbox::system::obscured_config $config] + puts "url:$url query:'$query' verb:%verb% config:'$sanconfig'" + return + } + }] + proc $commandname {args} $procbody + } + + proc rest_call_complete {key func status args} { + variable call_data + if {[catch { + upvar 1 token token + #parray token + #This assumes there is only one call in flight unless key is made unique per call + set call_data($ns) [array get token] + } errMsg]} { + puts "rest_call_complete error: $errMsg" + } + puts $args + #puts "->$ns $func $status $args" + } + + proc http_call_complete {func callid tok} { + variable call_data + set call_data($func,$callid,http) [array get $tok] + set rcode [http::ncode $tok] + if {![string match 2* $rcode]} { + upvar 0 $tok status + if {$rcode ne ""} { + set data [list NETBOX ERROR HTTP $rcode] + if {$rcode eq "302"} { + #is location always capitalised this way by http? It can vary in raw server responses + #tcllib rest had it as Location - which definitely breaks in at least some cases. + #(perhaps http lib normalized it?) + set meta [dict get $status(meta)] + set keys [dict keys $meta] + set keyname [lsearch -inline -nocase $keys location] + if {$keyname ne ""} { + lappend data location [dict get $meta $keyname] + } else { + lappend data location "(unknown)" ;#can this even happen? + } + #For a rest api - we probably shouldn't follow redirects (review) + #It's probably generally better to return the error and get the user to update their URL + #there may be cases where redirect-following is needed - add an option for it? + } else { + if {$status(totalsize) > 0} { + lappend data errorbody $status(body) + } + } + } else { + #no HTTP response code - may be a socket error + set data [list NETBOX ERROR OTHER $status(status)] + if {[info exists status(error)]} { + lappend data errortext $status(error) + } + } + set call_data($func,$callid,result) [list ERROR $data] + http::cleanup $tok + return + } + set call_data($func,$callid,result) [list OK [http::data $tok]] + http::cleanup $tok + return + } +} + +tcl::namespace::eval punk::netbox { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace punk::netbox}] + #[para] Core API functions for punk::netbox + #[list_begin definitions] + + variable PUNKARGS + + variable has_tls + set has_tls [expr {![catch {package require tls}]}] + + if {$has_tls} { + ::http::register https 443 ::tls::socket + } + + + variable contexts [dict create] + variable context_id 0 + + namespace eval argdoc { + variable PUNKARGS + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + } + + + + proc api_context_names {} { + variable contexts + return [dict keys $contexts] + } + + lappend PUNKARGS [list { + @id -id ::punk::netbox::api_contexts + @cmd -name punk::netbox::api_contexts -help\ + "Show in-memory api contexts. + These are named contexts for calling + the NETBOX rest api. + They are loaded using api_contexts_load from + a .toml configuration file, or created using + api_context_create." + -return -default table -choices {table tableobject dict} + -fields -type list -default {url tokentail comment} -choices {url token tokentail comment *} -choicemultiple {0 -1} -choicerestricted 0 -help\ + "The * token can be included in the list of specified + fields, and represents any other available fields found + from the matched contexts" + @values -min 0 -max 1 + globname -default * -help\ + "pattern to match the context name(s)" + }] + proc api_contexts {args} { + set argd [punk::args::parse $args withid ::punk::netbox::api_contexts] + lassign [dict values $argd] leaders opts values received + set returntype [dict get $opts -return] + set fields [dict get $opts -fields] + set globname [dict get $values globname] + + + variable contexts + set matches [dict keys $contexts $globname] + + + if {"*" in $fields} { + set starposn [lsearch -exact $fields *] + set before [lrange $fields 0 $starposn-1] + set after [lrange $fields $starposn+1 end] + set allspecified [list {*}$before {*}$after] + # use * as placeholder for all others not specified - retain order of specified columns + set fields [list] + #check fields in all matches + set starfields [list] + if {"tokentail" ni $allspecified} { + #calculated column + lappend starfields tokentail + } + foreach k $matches { + set contextinfo [dict get $contexts $k] + dict for {valkey valinfo} $contextinfo { + if {$valkey ni $allspecified && $valkey ni $starfields} { + lappend starfields $valkey + } + } + } + set fields [list {*}$before {*}$starfields {*}$after] + } + + + switch -- $returntype { + table - tableobject { + package require textblock + set t [textblock::table -return tableobject -minwidth 75 -headers [list contextid {*}$fields]] + foreach k $matches { + set contextinfo [dict get $contexts $k] + set tokentail "" + if {"tokentail" in $fields} { + #computed column + if {[dict exists $contextinfo token]} { + set tokentail [string range [dict get $contextinfo token value] end-5 end] + } + } + set rowdata [list $k] + foreach f $fields { + if {[dict exists $contextinfo $f value]} { + lappend rowdata [dict get $contextinfo $f value] + } else { + if {$f eq "tokentail"} { + lappend rowdata $tokentail + } else { + lappend rowdata "" + } + } + } + $t add_row $rowdata + } + if {$returntype eq "table"} { + set tableview [$t print] + $t destroy + return $tableview + } else { + return $t + } + } + dict { + set result [dict create] + foreach k $matches { + set contextinfo [dict get $contexts $k] + set tokentail "" + if {"tokentail" in $fields} { + #computed column + if {[dict exists $contextinfo token]} { + set tokentail [string range [dict get $contextinfo token value] end-5 end] + } + } + dict set result $k {} ;#ensure record is output even if empty fieldlist + foreach f $fields { + if {[dict exists $contextinfo $f value]} { + dict set result $k $f [dict get $contextinfo $f value] + } else { + if {$f eq "tokentail"} { + dict set result $k tokentail $tokentail + } + } + } + #dict for {valkey valinfo} $contextinfo { + # dict set result $k $valkey [dict get $valinfo value] + #} + } + return $result + } + } + } + + + + #get api handle(s) for a netbox server (with url and token) to pass to the punk::netbox api functions + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::netbox::api_context_load + @cmd -name punk::netbox::api_context_load\ + -summary\ + "Load API token contexts from storage."\ + -help\ + "Load API context information (url token) + from a .toml file in the data directory + or from a specified file. + + To create an initial file, use api_context + to create one or more named configurations + specifying the url and authentication token. + Then use api_context_save to persist them. + + Returns the names of the loaded contexts." + @opts + -contextname -default * -help\ + "Name of an API context or a pattern for + which contexts to load from the file." + -nowarnings -type none -help\ + "Suppress warnings emitted to stderr. + Will not stop error if datafile is not found" + @values + filepath -default "" -type file + }] + } + proc api_context_load {args} { + set argd [punk::args::parse $args withid ::punk::netbox::api_context_load] + lassign [dict values $argd] leaders opts values received + set contextglob [dict get $opts -contextname] + set filepath [dict get $values filepath] + set nowarnings [dict exists $received -nowarnings] + + if {$filepath eq ""} { + set filepath [_datafile -quiet] + } + if {![file exists $filepath]} { + error "No existing datafile at '$filepath'\nUse api_context_create/api_context_save to configure and save contexts" + } + package require tomlish + set tomldata [readFile $filepath] + set tomlish [tomlish::from_toml $tomldata] ;#intermediate (unvalidated) representation of toml data - maintaining whitespace and comments + set tomldict [tomlish::to_dict $tomlish] ;#lossy conversion to a programmatic structure (loss is of comments, whitespace) + variable contexts + #merge into any existing-in-memory loaded/created contexts + set loaded [list] + dict for {contextid contextinfo} $tomldict { + if {[string match $contextglob $contextid]} { + if {!$nowarnings} { + if {![dict exists $contextinfo url]} { + puts stderr "api_context_load warning: Loaded context $contextid is missing 'url' key" + } + if {![dict exists $contextinfo token]} { + puts stderr "api_context_load warning: Loaded context $contextid is missing 'token' key" + } + } + dict set contexts $contextid $contextinfo + lappend loaded $contextid + } + } + return $loaded + } + + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::netbox::init + @cmd -name punk::netbox::init\ + -summary\ + "Load all api token contexts."\ + -help\ + "This is a convenience function to call api_context_load + to load all available API token contexts with the default + data-file path being determined with the _datafile function." + @leaders + @opts + -quiet -type none -help\ + "Suppress status messages emitted to stdout. + Will not suppress the error raised if no datafile is available" + -nowarnings -type none -help\ + "Suppress warnings related to missing urls/tokens that are emitted + to stderr" + @values -min 0 -max 0 + }] + } + proc init {args} { + set argd [punk::args::parse $args withid ::punk::netbox::init] + set received [dict get $argd received] + set be_quiet [dict exists $received -quiet] + set nowarnings [dict exists $received -nowarnings] + if {!$be_quiet} { + set filepath [_datafile] + } else { + set filepath [_datafile -quiet] + } + if {![file exists $filepath]} { + error "No existing datafile at '$filepath'\nCall api_context_load with a path to a .toml file with context records\nor use api_context_create/api_context_save." + } + if {!$be_quiet} { + puts stdout "Loading API token contexts from $filepath" + } + if {$nowarnings} { + api_context_load -nowarnings + } else { + api_context_load + } + if {!$be_quiet} { + puts stdout "Table produced by api_contexts" + puts stdout [api_contexts] + } + variable contexts + if {!$be_quiet} { + puts stdout "The contextid value is used as the 1st argument of most punk::netbox api functions" + puts stdout "If a raw token is required it can be retrieved with: api_context_get token" + puts stdout "[dict size $contexts] contexts loaded" + } + return [dict size $contexts] + } + + lappend PUNKARGS [list { + @id -id ::punk::netbox::api_context_create + @cmd -name punk::netbox::api_context_create -help\ + "Create an in-memory configuration for an API context. + This consists of a name (contextid) under which a + url and authentication token are stored. + It can optionally be persisted using api_context_save + to the file of your choice, or to a reasonable default + location. (see _datafile). + The api_context_load function can be used to retrieve + previously stored contextids instead of calling this + function each time. + + A contextid is required when calling the netbox rest api + functions such as ipam::vrfs + This allows easy intermixing of calls to either the same + or different servers using the different permissions + granted by each token. + " + @leaders -min 1 -max 1 + contextid -type string -help\ + "Name for the api context. + If saved to a .toml file, this + will be the name of a toplevel table + containing configuration elements such + as url and token." + @opts + -property_value -type list -minsize 2 -maxsize 2 -multiple 1 -help\ + "custom property and value. + e.g + property_value {comment {test comment}}" + @values -min 2 -max 2 + url -type string -help\ + "Base url of netbox server" + token -type string -help\ + "Netbox API authentication token" + }] + proc api_context_create {args} { + set argd [punk::args::parse $args withid ::punk::netbox::api_context_create] + lassign [dict values $argd] leaders opts values received + set contextid [dict get $leaders contextid] + if {[dict exists $received -property_value]} { + set propvals [dict get $opts -property_value] ;#multiple - as pairs + } else { + set propvals [list] + } + set baseurl [dict get $values url] + set token [dict get $values token] + + variable contexts + if {[dict exists $contexts $contextid]} { + error "api_context_create a context with id '$contextid' already exists." + } + set allprops [dict create url [dict create type STRING value $baseurl] token [dict create type STRING value $token]] + foreach pv $propvals { + lassign $pv p v + if {$p in {url token}} { + puts stderr "ignoring -property_value $p - invalid - already specified in arguments" + } + #todo - multiline? + dict set allprops $p [dict create type STRING value $v] + } + dict set contexts $contextid $allprops + return $contextid + } + namespace eval argdoc { + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::netbox::api_context_get + @cmd -name punk::netbox::api_context_get -help\ + "Get api context fields for a single context. + A unique prefix of any loaded context may be + used." + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + Contextids can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @values -min 0 -max -1 + field -type string -multiple 1 -optional 1 -help\ + "If no field arguments are supplied, all will + be retrieved. + Note that a non-existant field name will produce + an empty string element in the result list for + that position. This is indistinguishable from an + existent field with an empty string as the value. + + As an alternative, the api_contexts function with + the -return dict argument can be used instead to + access multiple fields for multiple apicontextids. + " + }] + } + proc api_context_get {args} { + set argd [punk::args::parse $args withid ::punk::netbox::api_context_get] + lassign [dict values $argd] leaders opts values received + set contextid [dict get $leaders apicontextid] + if {[dict exists $received field]} { + set fields [dict get $values field] ;#-multiple true - so always a list + } else { + set fields [list] + } + + variable contexts + set cdata [dict get $contexts $contextid] + set result [list] + if {![llength $fields]} { + set fields [dict keys $cdata] + } + foreach f $fields { + if {[dict exists $cdata $f]} { + lappend result [dict get $cdata $f value] + } else { + lappend result "" + } + } + return $result + } + + lappend PUNKARGS [list { + @id -id ::punk::netbox::get_status + @cmd -name punk::netbox::get_status\ + -summary\ + "Get status of previous -ASYNC call."\ + -help\ + "Retrieve the status from a previous punk::netbox::?ns::? + call which was run with -ASYNC. + + An error will be raised if the asynctoken is not valid or + if its result has already been retrieved with get_result. + + Returns PENDING, OK or ERROR + + It will not return the error text or result. + + It will not clear the error/result. + " + @values -min 1 -max 1 + asynctoken -type string -help\ + "A token as returned from a punk::netbox command when + it was given the -ASYNC flag" + }] + proc get_status {asynctoken} { + upvar ::punk::netbox::system::call_data call_data + if {![info exists call_data($asynctoken,httptoken)]} { + error "No such asynctoken: $asynctoken" + } + if {![info exists call_data($asynctoken,http)]} { + return PENDING + } else { + #even though we could return the raw result here, + #we don't - because the user should call get_result for cleanup. + return [lindex $call_data($asynctoken,result) 0] ;#OK|ERROR + } + } + lappend PUNKARGS [list { + @id -id ::punk::netbox::is_finished + @cmd -name punk::netbox::is_finished\ + -summary\ + "Test if result/error of previous -ASYNC call available."\ + -help\ + "Return an integer 0,1 or 2 indicating whether the result/error from a + previous punk::netbox::?ns::? call which was run with -ASYNC + is ready. + 0 indicates the request is still pending. + 1 indicates there is a result available. + 2 indicates there the command completed with an error. + + An error will be raised if the token is not valid or if its + result has already been retrieved with get_result." + @values -min 1 -max 1 + asynctoken -type string -help\ + "A token as returned from a punk::netbox command when + it was given the -ASYNC flag" + }] + proc is_finished {asynctoken} { + upvar ::punk::netbox::system::call_data call_data + if {![info exists call_data($asynctoken,httptoken)]} { + error "No such asynctoken: $asynctoken" + } + if {![info exists call_data($asynctoken,http)]} { + return 0 + } else { + if {[lindex $call_data($asynctoken,result) 0] eq "OK"} { + return 1 + } else { + return 2 + } + } + } + + lappend PUNKARGS [list { + @id -id ::punk::netbox::get_result_http + @cmd -name punk::netbox::get_result_http\ + -summary\ + "Get results of previous -ASYNC call."\ + -help\ + "Retrieve the http information from a previous punk::netbox::?ns::? + call which was run with -ASYNC. + + An error will be raised if the asynctoken is not valid or + if its result has already been retrieved with get_result. + + If the call has not yet returned or timed out, this call + will wait until the http token's status has been set. + + This call does not invalidate/clean-up the asynctoken and + if used, should be called prior to get_result. + " + @values -min 1 -max 1 + asynctoken -type string -help\ + "A token as returned from a punk::netbox command when + it was given the -ASYNC flag" + }] + proc get_result_http {asynctoken} { + upvar ::punk::netbox::system::call_data call_data + if {![info exists call_data($asynctoken,httptoken)]} { + error "No such asynctoken: $asynctoken" + } + set httptok $call_data($asynctoken,httptoken) + if {![info exists call_data($asynctoken,http)]} { + http::wait $httptok + } + return $call_data($asynctoken,http) + } + + lappend PUNKARGS [list { + @id -id ::punk::netbox::get_result + @cmd -name punk::netbox::get_result\ + -summary\ + "Get results of previous -ASYNC call."\ + -help\ + "Retrieve the result from a previous punk::netbox::?ns::? + call which was run with -ASYNC. + + An error will be raised for a call that was unsuccessful. + An error will be raised if the asynctoken is not valid or + if its result has already been retrieved with get_result. + + If the call has not yet returned or timed out, this call + will wait until the http token's status has been set." + @values -min 1 -max 1 + asynctoken -type string -help\ + "A token as returned from a punk::netbox command when + it was given the -ASYNC flag" + }] + proc get_result {asynctoken} { + upvar ::punk::netbox::system::call_data call_data + + set debug 0 ;#todo -DEBUG flag? + + if {![info exists call_data($asynctoken,httptoken)]} { + error "No such asynctoken: $asynctoken" + } + set httptok $call_data($asynctoken,httptoken) + if {![info exists call_data($asynctoken,http)]} { + http::wait $httptok + } + + #set command [lindex [split $asynctoken ,] 0] ;#review - assumes no comma in command name - not a great assumption! + set command $call_data($asynctoken,command) + + set resultlist $call_data($asynctoken,result) + set returntype $call_data($asynctoken,returntype) + set config $call_data($asynctoken,config) + if {$returntype in "json jsondump"} { + #if we leave 'result' = json - we get a dict instead of json :/ + #The 'result' key seems to tell ::rest what post-processor to use to translate it *from* that to a tcl dict (or in xml case a nested list) + #sort of.. + #xml - takes xml produces a list + #json - takes json produces a dict + #discard - 'return -code ok' + #auto - *basic* detect xml or json and do as above + #tdom - takes xml - produces a tdom documentElement + #raw - just returns the data + dict set config result raw + } + + + #status is #OK|ERROR + lassign $resultlist status resulttext + #resulttext NETBOX ERROR ... + if {$status eq "ERROR"} { + set etype [lindex $resulttext 2] + #--------------------------------- + #this works - but the raw json seems more useful, and less prone to secondary errors + #--------------------------------- + #if {$etype eq "HTTP"} { + # #return -code error -errorcode [list NETBOX HTTP $ncode] $resulttext + # set errorbody [lindex $resulttext 5] + # if {$errorbody ne ""} { + # if {[catch { + # set result [list {*}[lrange $resulttext 0 4] [::rest::format_[dict get $config result] $errorbody]] ;#crude detection of xml/json - REVIEW + # #if xml - we don't get a dict - but netbox shouldn't output that anyway. + # #would be better just to output raw? + # } errM]} { + # set result $resulttext + # } + # } else { + # set result $resulttext + # } + #} else { + # set result $resulttext + #} + #--------------------------------- + #if we try to pass any of the error results to the requested returntypes below - it would only make sense for JSON anyway? + set result $resulttext + set errorcode [list NETBOX $etype [lindex $resulttext 3]] + if {!$debug} { + #clean up our copy of the http token data even on error + array unset call_data $asynctoken,* + } + return -code error -errorcode $errorcode $result + } + + #This is another main reason we couldn't just use ::rest lib as-is. + #Servers sometimes respond with empty body + #::rest lib tries to parse empty string as JSON and just emits an ugly error + #we may do the same if one of the returntype branches fails - but at least the user has a choice. + if {$resulttext ne ""} { + #review - could get nest structure from xml - but not relevant to netbox + #parsing json could fail here too + #eg when config result is 'json' - parse json to a dict + set result [::rest::format_[dict get $config result] $resulttext] + } else { + set result "" + } + + if {!$debug} { + #clean up our copy of the http token data + array unset call_data $asynctoken,* + } + + #try catch - return errorcode: NETBOX OUTPUTFORMATTING ? + switch -exact -- $returntype { + showpagedict { + return [punk::lib::showdict $result !@@results @@results/@*/@*.@*] + } + showpagedict2 { + return [punk::lib::showdict $result @@results/@*/@*.@* !@@results] + } + showdict { + if {$command eq "::punk::netbox::status"} { + #we get duplicate django-version for %showdict% - todo - something. + return [punk::lib::showdict $result @@django-version @@installed-apps/@*.@* !@@installed-apps] + } + return [punk::lib::showdict $result *] + } + showdict2 { + if {$command eq "::punk::netbox::status"} { + #we get duplicate django-version for %showdict% - todo - something. + return [punk::lib::showdict $result @@installed-apps/@*.@* !@@installed-apps] + } + return [punk::lib::showdict $result */*] + } + showlist { + return [punk::lib::showdict -roottype list $result] + } + showlistofdicts { + return [punk::lib::showdict $result @*/@*.@*] + } + jsondump { + package require huddle::json + #pretty-print via huddle (inefficient review) + set h [huddle::json::json2huddle parse $result] + return [huddle::jsondump $h] + } + linelist { + set ret "" + foreach r $result { + append ret $r \n + } + return $ret + } + default { + #plain result: (list or dict) or json - the counterintuitive 'result' field set to raw above sets the rest call's resulting format to json + return $result + } + } + + } + + + + 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::netbox::_datafile + @cmd -name punk::netbox::_datafile -help\ + "Get the path for the default storage file + 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 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. + " + @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 _datafile {args} { + set argd [punk::args::parse $args withid ::punk::netbox::_datafile] + lassign [dict values $argd] leaders opts values received + set be_quiet [dict exists $received -quiet] + + set was_noisy 0 + if {[info exists ::env(XDG_DATA_HOME)]} { + set data_home $::env(XDG_DATA_HOME) + } else { + 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 (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 + } + set punk_netbox_data_dir [file join $data_home punk netbox] + if {!$be_quiet && ![file exists $punk_netbox_data_dir]} { + set msg "punk::netbox data storage folder at $punk_netbox_data_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::netbox::_datafile - call with -quiet option to suppress these messages" + } + return [file join $punk_netbox_data_dir netbox_api_contexts.toml] + } + + + lappend PUNKARGS [list { + @id -id ::punk::netbox::api_context_save + @cmd -name punk::netbox::api_context_save -help\ + "" + @values + contextid -type string -help\ + "Name for the api context. + If saved to a .toml file, this + will be the name of a toplevel table + containing configuration elements such + as url and token." + filepath -default "" -optional 1 -type file -help\ + "Path of .toml configuration file containing + API url and token information. + If empty it will store under XDG_DATA_DIR + if the env var is defined, or in the + corresponding location within ~/.local/share. + In both cases the subfolder netbox/punk will + be used. + These locations are fairly reasonable for + sensitive data - but as tokens are not + encrypted, a proper security store should be + used instead if your risk-policy requires + more serious security. + " + }] + proc api_context_save {args} { + set argd [punk::args::parse $args withid ::punk::netbox::api_context_save] + lassign [dict values $argd] leaders opts values received + set contextid [dict get $values contextid] + set filepath [dict get $values filepath] + + variable contexts + if {![dict exists $contexts $contextid]} { + error "punk::netbox::api_context_save error. No context with id '$contextid' exists. Load from file, or create it using punk::netbox::api_context" + } + if {$filepath eq ""} { + set filepath [_datafile -quiet] + set filefolder [file dirname $filepath] + if {![file exists $filefolder]} { + file mkdir $filefolder + } + } + set configdir [file dirname $filepath] + if {![file exists $configdir]} { + error "api_context_save error: folder $configdir doesn't exist" + } + package require tomlish + if {[file exists $filepath]} { + set existing_toml [readFile $filepath] + set tomlish [tomlish::from_toml $existing_toml] + set data_dict [tomlish::to_dict $tomlish] + if [dict exists $data_dict $contextid] { + #todo - nondestructive merge - don't destroy comments/formatting of existing records + #if we use to_dict on the existing tomlish - we lose comments etc + #also from_dict doesn't yet produce canonical nice-for-humans tomlish/toml + #merge + puts stderr "contextid '$contextid' exists in file $filepath" + puts stderr "Merge not implemented.." + set newfiledata "" + } else { + #append to existing toml data + set newdict [dict create $contextid [dict get $contexts $contextid]] + #we store our contexts in a structure already suitable for toml + # (ie one where we tag strings,ints e.g {type STRING value "etc"}) + set newtomlish [tomlish::from_dict $newdict] + set newtoml [tomlish::to_toml $newtomlish] + set newfiledata $existing_toml\n$newtoml + } + } else { + set newdict [dict create $contextid [dict get $contexts $contextid]] + set newtomlish [tomlish::from_dict $newdict] + set newtoml [tomlish::to_toml $newtomlish] + set newfiledata $newtoml + } + + if {$newfiledata ne ""} { + writeFile $filepath $newfiledata + puts stderr "saved [string length $newfiledata] bytes to '$filepath'" + } + } + + + namespace eval argdoc { + set _page_options { + -limit -default 100 -type integer -help\ + "Each REST query returns a maximum number + of results. This can be set to 0 to mean + no limit - but it is still restricted to + the max configured on the server. (1000?) + + This is effectively the page-size of the + results. To retrieve more than a page, the + next and previous urls can be iterated over." + -offset -default 0 -type integer + } + set _create_update_options { + -created + -created__gte + -created__lte + -last_updated + -last_updated__gte + -last_updated__lte + } + set _tenant_options { + -tenant_group_id + -tenant_group_id__n + -tenant_group + -tenant_group__n + -tenant_id + -tenant_id__n + -tenant + -tenant__n + } + set _region_options { + -region_id + -region + } + set _site_options { + -site_group_id + -site_group_id__n + -site_group + -site_group__n + -site_id + -site_id__n + -site + -site__n + } + set _group_options { + -group_id + -group_id__n + -group + -group__n + } + set _contact_options { + -contact + -contact__n + -contact_role + -contact_role__n + -contact_group + -contact_group__n + } + set _role_options { + -role_id + -role_id__n + -role + -role__n + } + set _filter_string [list\ + "ie \n Exact match\n(case-insensitive)"\ + "nie \n Inverse exact match\n(case-insensitive)"\ + "n \n Not equal to"\ + "ic \n Contains\n (case-insensitive)"\ + "nic \n Does not contain\n (case-insensitive)"\ + "isw \n Starts with\n (case-insensitive)"\ + "nisw \n Does not start with\n (case-insensitive)"\ + "iew \n Ends with\n (case-insensitive)"\ + "niew \n Does not end with\n (case-insensitive)"\ + "empty \n Is empty/null"\ + ] + set _filter_number [list\ + "n \n Not equal to"\ + "lte \n Less than or equal"\ + "lt \n Less than"\ + "gte \n Greater than or equal"\ + "gt \n Greater than"\ + ] + set _CUSTOM_PARAMS { + -CUSTOM_PARAM -type list -minsize 2 -maxsize 2 -multiple 1 -help\ + "Specify a parameter not in this API + e.g -CUSTOM_PARAM {mytag blah}" + } + set _RETURN_PAGEDICT { + -RETURN -type string -choices {dict showpagedict showpagedict2 json jsondump} -choicelabels { + dict\ + " Tcl dictionary + (fastest)" + showpagedict\ + " human readable dict display + with same order as dict." + showpagedict2\ + " human readable dict display + results first, page metadata last." + } -help\ + "Options for returned data. + Note that showdict results are relatively slow, especially for large resultsets" + } + set _RETURN_DICT { + -RETURN -type string -choices {dict showdict showdict2 json jsondump} -choicelabels { + dict\ + " Tcl dictionary + (fastest)" + showdict\ + " human readable dict display + with same order as dict." + showdict2\ + " human readable dict display + results first metadata last." + } -help\ + "Options for returned data. + Note that showdict results are relatively slow, especially for large resultsets" + } + set _RETURN_LIST { + -RETURN -type string -choices {list linelist showlist json jsondump} -choicelabels { + list\ + " Tcl list + (fastest)" + linelist\ + " raw list with newline after each item" + showlist\ + " human readable list display" + } -help\ + "Options for returned data. + Note that showlist results are relatively slow, especially for large resultsets" + } + set _RETURN_LISTOFDICTS { + -RETURN -type string -choices {list linelist showlist json jsondump} -choicelabels { + list\ + " Tcl list + (fastest)" + linelist\ + " raw list with newline after each item" + showlistofdicts\ + " human readable display list of dicts" + } -help\ + "Options for returned data. + Note that showlist results are relatively slow, especially for large resultsets" + } + set _RETURN_STATUS { + -RETURN -type string -default showdict2 -choices {dict showdict showdict2 json jsondump} -choicelabels { + dict\ + " Tcl dictionary" + showdict\ + " human readable dict display" + showdict2\ + " human readable dict display + installed-apps first." + } -help\ + "Options for returned data." + } + + set _name_filter_help "Paired search filter for name:\n" + append _name_filter_help [textblock::list_as_table -columns 4 -show_hseps 1 $_filter_string] + + set _description_filter_help "Paired search filter for description:\n" + append _description_filter_help [textblock::list_as_table -columns 4 -show_hseps 1 $_filter_string] + + set string_filter_help "Paired search filter for string:\n" + append _string_filter_help [textblock::list_as_table -columns 4 -show_hseps 1 $_filter_string] + + #n, lte, lt, gte, gt + #e.g virtualization/virtual-machine vcpus, memory, disk + set number_filter_help "Paired search filter for number:\n" + append _number_filter_help [textblock::list_as_table -columns 3 -show_hseps 1 $_filter_number] + } + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::status + @cmd -name punk::netbox::status -help\ + "status_list + GET request for endpoint /status/ + + Netbox's current operational status + " + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_STATUS]\ + { + -ASYNC -type none + @values -min 0 -max 0 + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::status api/status/ -verb get -body none + + #test - to see what the create_interface procs look like with a callback + #(they are not flexible enough argument-wise for this usecase) + #with a static callback baked into the function - it also gives no way to reliably determine + #which request matched which call if there are concurrent calls in flight for the same function/endpoint especially if args are the same + #(order of completion could presumably not always match call order) + #presumably an http::wait is required on each call, and they must be processed in order? + set RESTAPI(getstatus) { + url https://www.netbox1.intx.com.au/api/status/ + method get + headers {Authorization {Token bogus} content-type "application/json"} + callback {::punk::netbox::system::rest_call_complete RESTAPI} + error-body false + opt_args {test etc} + req_args {force} + } + #namespace eval ::punk::netbox::spud {} + ::rest::create_interface ::punk::netbox::RESTAPI + # + + + #test function - todo use punk::netbox::system::make_rest_func + #proc vrfs {args} { + # set argd [punk::args::parse $args withid ::punk::netbox::vrfs] + # lassign [dict values $argd] leaders opts values received + # set apicontextid [dict get $leaders apicontextid] + # set query [dict create] + # dict for {k v} $opts { + # if {$k eq "-CUSTOM_PARAM"} { + # foreach custval $v { + # lassign $custval param value + # dict set query $param $value + # } + # } elseif {[string match *_FILTER $k]} { + # set field [string range [string tolower [lindex [split $k _] 0]] 1 end] ;# -NAME_FILTER -> name + # foreach fv $v { + # lassign $fv filter value + # dict set query ${field}__$filter $value + # } + # } else { + # dict set query [string range $k 1 end] $v + # } + # } + # variable contexts + # if {![dict exists $contexts $apicontextid]} { + # error "specified contextid '$apicontextid' not found" + # } + # set config [dict create\ + # result json\ + # ] + # dict set config headers [list Authorization [list Token [dict get $contexts $apicontextid token value]]] + + # #variable headerdict + # #set config [dict create\ + # # headers $headerdict\ + # # result json\ + # #] + # #variable url + # set url [dict get $contexts $apicontextid url value] + + # puts "${url}api/ipam/vrfs/ '$query' '$config'" + # rest::get ${url}api/ipam/vrfs/ $query $config + #} + + #set ipam(vrfs) [dict create\ + # url https://www.netbox1.intx.com.au/api/ipam/vrfs/\ + # method get\ + # result json\ + # body none\ + # headers $headerdict\ + # opt_args {id: name: limit:100 offset:0} + #] + #set ipam(ip-addresses) [dict create\ + # url https://www.netbox1.intx.com.au/api/ipam/ip-addresses/\ + # method get\ + # headers $headerdict\ + # opt_args {parent: limit:100 offset:0} + #] + #set ipam(prefixes) [dict create\ + # url https://www.netbox1.intx.com.au/api/ipam/prefixes/\ + # method get\ + # headers $headerdict\ + # opt_args {prefix: limit:100 offset:0} + #] + #rest::create_interface ::punk::netbox::ipam + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::netbox ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval punk::netbox::dcim { + namespace export {[a-z]*} + namespace eval argdoc { + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::dcim::devices_list + @cmd -name punk::netbox::dcim::devices_list -help\ + "tenancy_tenants_list + GET request for endpoint /dcim/devices/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help\ + {${$::punk::netbox::argdoc::_number_filter_help}} + -name + -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} + -asset_tag -type string + -ASSET_TAG_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + -face -type string + -face__n -type string + -position -type integer + -POSITION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -airflow -type string + -airflow__n -type string + -vc_position -type integer + -VC_POSITION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -vc_priority -type integer + -VC_PRIORITY_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q -type string + -tag -type string -multiple true + -tag__n -type string + }\ + [set ::punk::netbox::argdoc::_tenant_options]\ + [set ::punk::netbox::argdoc::_contact_options]\ + { + -local_context_data + -manufacturer_id + -manufacturer_id__n + -manufacturer + -manufacturer__n + -device_type_id + -device_type_id__n + -role_id + -role_id__n + -role + -role__n + -parent_device_id + -parent_device_id__n + -platform_id + -platform_id__n + -platform + -platform__n + }\ + [set ::punk::netbox::argdoc::_group_options]\ + [set ::punk::netbox::argdoc::_region_options]\ + [set ::punk::netbox::argdoc::_site_options]\ + { + -location_id -type integer + -location_id__n -type integer + -rack_id -type integer + -rack_id__n -type integer + -cluster_id -type integer + -cluster_id__n -type integer + -model -type string + -model__n -type string + -status -type string + -status__n -type string + -mac_address -type string + -MAC_ADDRESS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + -serial -type string + -SERIAL_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + -virtual_chassis_id -type integer + -virtual_chassis_id__n -type integer + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::dcim::devices_list api/dcim/devices/ -verb get -body none +} + +tcl::namespace::eval punk::netbox::ipam { + namespace export {[a-z]*} + namespace eval argdoc { + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::ipam::vrfs_list + @cmd -name punk::netbox::ipam::vrfs_list -help\ + "ipam_vrfs_list + GET request for endpoint /ipam/vrfs/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -name + -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} + -rd -type string -help\ + "Route distinguisher in any format" + -enforce_unique + -description -type string -help "Exact Match (case sensitive)" + -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_description_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q + -tag -type string -multiple true + }\ + [set ::punk::netbox::argdoc::_tenant_options]\ + [set ::punk::netbox::argdoc::_region_options]\ + [set ::punk::netbox::argdoc::_site_options]\ + [set ::punk::netbox::argdoc::_group_options]\ + [set ::punk::netbox::argdoc::_role_options]\ + { + -status + -available_on_device + -available_on_virtualmachine + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::vrfs_list api/ipam/vrfs/ -verb get -body none + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::ipam::vrfs_read + @cmd -name punk::netbox::ipam::vrfs_read -help\ + "ipam_vrfs_list + GET request for endpoint /ipam/vrfs/{id}" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this VRF" + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::vrfs_read api/ipam/vrfs/{id}/ -verb get -body none + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_list + @cmd -name punk::netbox::ipam::prefixes_list -help\ + "ipam_prefixes_list + GET request for endpoint /ipam/prefixes/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -is_pool + -mark_utilized + -description -type string -help "Exact Match (case sensitive)" + -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_description_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q -type string -help\ + "Query prefixes by substring" + -tag -type string -multiple true + }\ + [set ::punk::netbox::argdoc::_tenant_options]\ + [set ::punk::netbox::argdoc::_region_options]\ + [set ::punk::netbox::argdoc::_site_options]\ + [set ::punk::netbox::argdoc::_group_options]\ + [set ::punk::netbox::argdoc::_role_options]\ + { + -family + -prefix + -within + -within_include + -contains + -depth + -DEPTH_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -children + -CHILDREN_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -mask_length + -mask_length__gte + -mask_length__lte + -vlan_id -type integer + -vlan_id__n -type integer + -vlan_vid -type integer + -VLAN_VID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -vrf_id + -vrf + -status + -available_on_device + -available_on_virtualmachine + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::prefixes_list api/ipam/prefixes/ -verb get -body none + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_create + @cmd -name punk::netbox::ipam::prefixes_create -help\ + "ipam_prefixes_create + POST request for endpoint /ipam/prefixes/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + body -type string -help\ + "JSON string" + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::prefixes_create api/ipam/prefixes/{id}/ -verb post -body required + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_read + @cmd -name punk::netbox::ipam::prefixes_read -help\ + "ipam_prefixes_read + GET request for endpoint /ipam/prefixes/{id}/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this prefix" + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::prefixes_read api/ipam/prefixes/{id}/ -verb get -body none + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_available-ips_list + @cmd -name punk::netbox::ipam::prefixes_available-ips_list -help\ + "ipam_prefixes_available-ips_list + GET request for endpoint /ipam/prefixes/{id}/available-ips/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_LISTOFDICTS]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this prefix" + }\ + ] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::prefixes_available-ips_list api/ipam/prefixes/{id}/available-ips/ -verb get -body none + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_available-ips_create + @cmd -name punk::netbox::ipam::prefixes_available-ips_create -help\ + "ipam_prefixes_available-ips_create + POST request for endpoint /ipam/prefixes/{id}/available-ips/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_LIST]\ + { + @values -min 1 -max 2 + id -type integer -help\ + "A unique integer value identifying this prefix" + body -type string -default "" -help\ + { + If empty create a single IP with default values. + (next available IP in prefix) + + e.g Create 2 IPs: + [ + {"description": "ip1"}, + { + "description": "ip2", + "tenant": 5, + "dns_name": "test.intx.com.au" + } + ] + NOTE1: tenant is the tenant_id (why?) + NOTE: This always uses next available IPs. + To create a specific IP, use api/ipam/ip-addresses endpoint. + + The returned json is just an object if one address created, + but a list if multiple. :/ + + } + }\ + ] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::prefixes_available-ips_create api/ipam/prefixes/{id}/available-ips/ -verb post -body required + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_available-prefixes_list + @cmd -name punk::netbox::ipam::prefixes_available-prefixes_list -help\ + "ipam_prefixes_available-prefixes_list + GET request for endpoint /ipam/prefixes/{id}/available-prefixes/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_LISTOFDICTS]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this prefix" + }\ + ] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::prefixes_available-prefixes_list api/ipam/prefixes/{id}/available-prefixes/ -verb get -body none + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_available-prefixes_create + @cmd -name punk::netbox::ipam::prefixes_available-prefixes_create -help\ + "ipam_prefixes_available-prefixes_create + POST request for endpoint /ipam/prefixes/{id}/available-prefixes/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_LIST]\ + { + @values -min 1 -max 2 + id -type integer -help\ + "A unique integer value identifying this prefix" + body -type string -default "" -help\ + { + { + "prefix_length": 0 + } + } + }\ + ] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::prefixes_available-prefixes_create api/ipam/prefixes/{id}/available-prefixes/ -verb post -body required + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::ip-addresses_list + @cmd -name punk::netbox::ipam::ip-addresses_list -help\ + "ipam_ip-addresses_list + GET request for endpoint /ipam/ip-addresses/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -dns_name + -DNS_NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + -description -type string -help "Exact Match (case sensitive)" + -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_description_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q + -tag -multiple true -help\ + "If multiple -tag options supplied, + they are ANDed (review)" + }\ + [set ::punk::netbox::argdoc::_tenant_options]\ + [set ::punk::netbox::argdoc::_region_options]\ + [set ::punk::netbox::argdoc::_site_options]\ + [set ::punk::netbox::argdoc::_group_options]\ + [set ::punk::netbox::argdoc::_role_options]\ + { + -family + -parent + #need later netbox than 3.2.7 for -parent__n? + -parent__n + -address + -mask_length + -vrf_id + -vrf + -present_in_vrf_id + -present_in_vrf + -device + -device_id + -virtual_machine + -virtual_machine_id + -interface + -interface_id + -vminterface + -vminterface_id + -fhrpgroup_id + -assigned_to_interface + -status + -role + -available_on_device + -available_on_virtualmachine + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::ip-addresses_list api/ipam/ip-addresses/ -verb get -body none + + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::ip-addresses_create + @cmd -name punk::netbox::ipam::ip-addresses_create -help\ + "ipam_ip-addresses_create + POST request for endpoint /ipam/ip-addresses/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + body -type string -help\ + {JSON string + Example: + { + "address": "string", + "vrf": 0, + "tenant": 0, + "status": "active", + "role": "loopback", + "assigned_object_type": "string", + "assigned_object_id": 0, + "nat_inside": 0, + "dns_name": "string", + "description": "string", + "tags": [ + { + "name": "string", + "slug": "string", + "color": "string" + } + ], + "custom_fields": {} + } + Required: address (IPv4 or IPV6 address with mask) + } + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::ip-addresses_create api/ipam/ip-addresses/ -verb post -body required + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::ip-addresses_bulk_partial_update + @cmd -name punk::netbox::ipam::ip-addresses_bulk_partial_update -help\ + "ipam_ip-addresses_bulk_partical_update + PATCH request for endpoint /ipam/ip-addresses/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + body -type string -help\ + {JSON string + model: + { + "address": "string", + "vrf": 0, + "tenant": 0, + "status": "active", + "role": "loopback", + "assigned_object_type": "string", + "assigned_object_id": 0, + "nat_inside": 0, + "dns_name": "string", + "description": "string", + "tags": [ + { + "name": "string", + "slug": "string", + "color": "string" + } + ], + "custom_fields": {} + } + required: address + } + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::ip-addresses_bulk_partial_update api/ipam/ip-addresses/ -verb patch -body required + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::ip-addresses_read + @cmd -name punk::netbox::ipam::ip-addresses_read -help\ + "ipam_ip-addresses_read + GET request for endpoint /ipam/ip-addresses/{id}/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + id -type integer + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::ip-addresses_read api/ipam/ip-addresses/{id}/ -verb get -body none + + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::ip-addresses_delete + @cmd -name punk::netbox::ipam::ip-addresses_delete\ + -summary\ + "Delete an IP address by id."\ + -help\ + "ipam_ip-addresses_delete + DELETE request for endpoint /ipam/ip-addresses/{id}/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + id -type integer + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::ipam::ip-addresses_delete api/ipam/ip-addresses/{id}/ -verb delete -body none + +} + + +tcl::namespace::eval punk::netbox::tenancy { + namespace export {[a-z]*} + variable PUNKARGS + + namespace eval argdoc { + variable PUNKARGS + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::tenancy::tenants_list + @cmd -name punk::netbox::tenancy::tenants_list -help\ + "tenancy_tenants_list + GET request for endpoint /tenancy/tenants/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -name + -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} + -slug -type string + -SLUG_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + -description -type string + -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q -type string + -tag -type string -multiple true -help\ + "If multiple -tag options supplied, + they are ANDed (review)" + -tag__n -type string + }\ + [set ::punk::netbox::argdoc::_contact_options]\ + { + }\ + { + }\ + [set ::punk::netbox::argdoc::_group_options]\ + { + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } + + ::punk::netbox::system::make_rest_func_async ::punk::netbox::tenancy::tenants_list api/tenancy/tenants/ -verb get -body none +} + +tcl::namespace::eval punk::netbox::virtualization { + namespace export {[a-z]*} + + namespace eval argdoc { + variable PUNKARGS + variable DYN_CONTEXTNAMES + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + } + + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::clusters_list + @cmd -name punk::netbox::virtualization::clusters_list -help\ + "virtualization_clusters_list + GET request for endpoint /virtualization/clusters/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -name + -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q + -tag -multiple true + }\ + [set ::punk::netbox::argdoc::_tenant_options]\ + [set ::punk::netbox::argdoc::_contact_options]\ + { + -local_context_data + -status + -status_n + }\ + [set ::punk::netbox::argdoc::_region_options]\ + [set ::punk::netbox::argdoc::_site_options]\ + { + -platform + -platform__n + -mac_address + -MAC_ADDRESS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + -has_primary_ip + }\ + [set ::punk::netbox::argdoc::_group_options]\ + [set ::punk::netbox::argdoc::_role_options]\ + { + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } + + ::punk::netbox::system::make_rest_func_async ::punk::netbox::virtualization::clusters_list api/virtualization/clusters/ -verb get -body none + + namespace eval argdoc { + variable PUNKARGS + variable DYN_CONTEXTNAMES + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::virtual-machines_list + @cmd -name punk::netbox::virtualization::virtual-machines_list -help\ + "virtualization_virtual-machines_list + GET request for endpoint /virtualization/virtual-machines/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -name + -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} + -cluster -type string + -cluster__n -type string + -vcpus -type integer + -VCPUS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -memory -type integer -help\ + "Whole number" + -MEMORY_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -disk -type integer + -DISK_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q + -tag -multiple true + }\ + [set ::punk::netbox::argdoc::_tenant_options]\ + [set ::punk::netbox::argdoc::_contact_options]\ + { + -local_context_data + -status + -status_n + -cluster_group_id + -cluster_group_id__n + -cluster_group + -cluster_group__n + -cluster_type_id + -cluster_type_id__n + -cluster_type + -cluster_type__n + -cluster_id + -cluster_id__n + }\ + [set ::punk::netbox::argdoc::_region_options]\ + [set ::punk::netbox::argdoc::_site_options]\ + { + -platform + -platform__n + -mac_address + -MAC_ADDRESS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + -has_primary_ip + }\ + [set ::punk::netbox::argdoc::_group_options]\ + [set ::punk::netbox::argdoc::_role_options]\ + { + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } + + ::punk::netbox::system::make_rest_func_async ::punk::netbox::virtualization::virtual-machines_list api/virtualization/virtual-machines/ -verb get -body none + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::virtual-machines_create + @cmd -name punk::netbox::virtualization::virtual-machines_create -help\ + "virtualization_virtual-machines_create + GET request for endpoint /virtualization/virtual-machines/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + body -type string -help\ + "JSON string" + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::virtualization::virtual-machines_create api/virtualization/virtual-machines/ -verb post -body required + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::virtual-machines_bulk_delete + @cmd -name punk::netbox::virtualization::virtual-machines_bulk_delete\ + -summary\ + "DELETE *ALL* virtual machines."\ + -help\ + "virtualization_virtual-machines_bulk_delete + DELETE request for endpoint /virtualization/virtual-machines/ + HTTP code: 204 + " + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -FORCE -default 0 -type boolean -help\ + "Set to true to BULK delete *all* items at this endpoint" + }\ + { + @values -min 0 -max 0 + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::virtualization::virtual-machines_bulk_delete api/virtualization/virtual-machines/ -verb delete -body none + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::virtual-machines_read + @cmd -name punk::netbox::virtualization::virtual-machines_read -help\ + "virtualization_virtual-machines_read + GET request for endpoint /virtualization/virtual-machines/{id}" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this virtual machine" + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::virtualization::virtual-machines_read api/virtualization/virtual-machines/{id}/ -verb get -body none + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::virtual-machines_update + @cmd -name punk::netbox::virtualization::virtual-machines_update -help\ + "virtualization_virtual-machines_update + PUT request for endpoint /virtualization/virtual-machines/{id}" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 2 -max 2 + id -type integer -help\ + "A unique integer value identifying this virtual machine" + body -type string -help\ + "JSON string" + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::virtualization::virtual-machines_update api/virtualization/virtual-machines/{id}/ -verb put -body required + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::virtual-machines_delete + @cmd -name punk::netbox::virtualization::virtual-machines_delete\ + -summary\ + "Delete a single VM by id."\ + -help\ + "virtualization_virtual-machines_delete + DELETE request for endpoint /virtualization/virtual-machines/{id}" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying the virtual machine + to DELETE." + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::virtualization::virtual-machines_delete api/virtualization/virtual-machines/{id}/ -verb delete -body none + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::interfaces_list + @cmd -name punk::netbox::virtualization::interfaces_list -help\ + "virtualization_interfaces_list + GET request for endpoint /virtualization/interfaces/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -name + -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} + -enabled -type string + -mtu -type string + -MTU_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -mac_address -type string + -MAC_ADDRESS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + -description -type string + -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q + -tag -multiple true + -tag__n -multiple true + }\ + [set ::punk::netbox::argdoc::_tenant_options]\ + [set ::punk::netbox::argdoc::_contact_options]\ + { + -status + -status__n + -cluster -type string + -cluster__n -type string + -cluster_id -type integer + -cluster_id__n -type integer + -virtual_machine -type string + -virtual_machine__n -type string + -virtual_machine_id -type integer + -virtual_machine_id__n -type integer + }\ + [set ::punk::netbox::argdoc::_region_options]\ + [set ::punk::netbox::argdoc::_site_options]\ + { + -vrf_id -type integer + -vrf_id__n -type integer + -vrf -type string + -vrf__n -type string + -parent_id -type integer + -parent_id__n -type integer + -bridge_id -type integer + -bridge_id__n -type integer + }\ + [set ::punk::netbox::argdoc::_group_options]\ + [set ::punk::netbox::argdoc::_role_options]\ + { + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } + + ::punk::netbox::system::make_rest_func_async ::punk::netbox::virtualization::interfaces_list api/virtualization/interfaces/ -verb get -body none + +} + +tcl::namespace::eval punk::netbox::extras { + namespace export {[a-z]*} + + namespace eval argdoc { + variable PUNKARGS + variable DYN_CONTEXTNAMES + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::extras::tags_list + @cmd -name punk::netbox::extras::tags_list -help\ + "extras_tags_list + GET request for endpoint /extras/tags/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -name + -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} + -slug -type string + -color -type string + -description -type string + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + -ASYNC -type none + @values -min 0 -max 0 + }] + } + + ::punk::netbox::system::make_rest_func_async ::punk::netbox::extras::tags_list api/extras/tags/ -verb get -body none + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::extras::tags_create + @cmd -name punk::netbox::extras::tags_create -help\ + "extras_tags_create + GET request for endpoint /extras/tags/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + -ASYNC -type none + @values -min 1 -max 1 + body -type string -help\ + "JSON string" + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::extras::tags_create api/extras/tags/ -verb post -body required + + + set RESTAPI(create) { + url https://www.netbox1.intx.com.au/tags/create/ + method post + headers {Authorization {Token Bogus} content-type "application/json"} + callback {::punk::netbox::system::rest_call_complete RESTAPI} + body required + error-body false + } + ::rest::create_interface ::punk::netbox::extras::RESTAPI + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::extras::tags_bulk_delete + @cmd -name punk::netbox::extras::tags_bulk_delete -help\ + "extras_tags_bulk_delete + DELETE request for endpoint /extras/tags/ + HTTP code: 204 + " + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -FORCE -default 0 -type boolean -help\ + "Set to true to BULK delete all items at this endpoint" + }\ + { + -ASYNC -type none + @values -min 0 -max 0 + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::extras::tags_bulk_delete api/extras/tags/ -verb delete -body none + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::extras::tags_read + @cmd -name punk::netbox::extras::tags_read -help\ + "extras_tags_read + GET request for endpoint /extras/tags/{id}" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this tag" + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::extras::tags_read api/extras/tags/{id}/ -verb get -body none + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::extras::tags_update + @cmd -name punk::netbox::extras::tags_update -help\ + "extras_tags_update + PUT request for endpoint /extras/tags/{id} + A PUT update is a complete update of the tag. + It will reset any non-supplied fields + in the body to their default" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 2 -max 2 + id -type integer -help\ + "A unique integer value identifying this tag" + body -type string -help\ + "JSON string" + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::extras::tags_update api/extras/tags/{id}/ -verb put -body required + + + #namespace eval argdoc { + # lappend PUNKARGS [list\ + # { + # @dynamic + # @id -id ::punk::netbox::extras::tags_delete + # @cmd -name punk::netbox::extras::tags_delete -help\ + # "extras_tags_delete + # DELETE request for endpoint /extras/tags/{id} + # Deletes a specific tag identified by id." + # @leaders -min 1 -max 1 + # apicontextid -help\ + # "The name of the stored api context to use. + # A contextid can be created in-memory using + # api_context_create, or loaded from a .toml + # file using api_context_load."\ + # -choices {${$DYN_CONTEXTNAMES}} + # @opts + # }\ + # [set ::punk::netbox::argdoc::_RETURN_DICT]\ + # { + # @values -min 1 -max 1 + # id -type integer -help\ + # "A unique integer value identifying this tag" + # }] + #} + # 204 response with no JSON data on success + #The rest library will try to parse the empty string as json and fail + #it can parse "{}" but not "" + + + #404 for invalid id: + #allow: GET,PUT,PATCH,DELETE,HEAD,OPTIONS + #content-length: 23 + #content-type: application/json + #cross-origin-opener-policy: same-origin + #date: Tue,11 Nov 2025 17:46:04 GMT + #referrer-policy: same-origin + #server: nginx/1.26.2 + #vary: Accept,Cookie,Origin + #x-content-type-options: nosniff + #x-frame-options: SAMEORIGIN + + #{ + # "detail": "Not found." + #} + #::punk::netbox::system::make_rest_func ::punk::netbox::extras::tags_delete api/extras/tags/{id}/ -verb delete -body none + + + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::extras::tags_delete + @cmd -name punk::netbox::extras::tags_delete -help\ + "extras_tags_delete + DELETE request for endpoint /extras/tags/{id} + Deletes a specific tag identified by id." + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + -ASYNC -type none + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this tag" + }] + } + ::punk::netbox::system::make_rest_func_async ::punk::netbox::extras::tags_delete api/extras/tags/{id}/ -verb delete -body none + +} + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::netbox::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::netbox::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::netbox::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::netbox { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::netbox" + @package -name "punk::netbox" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::netbox + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topicg + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package punk::netbox + A library for calling netbox REST functions + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::punk::netbox::version" + } + proc get_topic_Contributors {} { + set authors {{Julian Noble }} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_features {} { + punk::args::lib::tstr -return string { + netbox /status/ endpoint + beginnings of /ipam/ endpoints + beginnings of /virtualization/ endpoints + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::netbox::about" + dict set overrides @cmd -name "punk::netbox::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::netbox + }] \n] + dict set overrides topic -choices [list {*}[punk::netbox::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::netbox::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::netbox::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::netbox::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES\ + ::punk::netbox\ + ::punk::netbox::dcim\ + ::punk::netbox::ipam\ + ::punk::netbox::tenancy\ + ::punk::netbox::virtualization\ + ::punk::netbox::extras\ +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::netbox [tcl::namespace::eval punk::netbox { + variable pkg punk::netbox + variable version + set version 0.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm index b44a9a33..73be222d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm @@ -133,6 +133,151 @@ tcl::namespace::eval punk::netbox::man { } } +tcl::namespace::eval punk::netbox::man::dcim { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + + tcl::namespace::eval devices { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + namespace eval argdoc { + variable PUNKARGS + #mark as @dynamic and ensure double-substitution present for dynamic parts + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [::list\ + {@dynamic}\ + [punk::args::resolved_def\ + -antiglobs {@leaders @values -RETURN}\ + -override { + @id {-id ::punk::netbox::man::dcim::devices::list } + apicontextid {-choices {${$DYN_CONTEXTNAMES}} } + }\ + ::punk::netbox::dcim::devices_list\ + ]\ + {-RETURN -default table -choices {table tableobject list}}\ + {-MAXRESULTS -type integer -default -1}\ + {@values -min 0 -max 0}\ + ] + } + #caution: must use ::list to avoid loop + proc list {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::dcim::devices::list"] + + set urlnext "" + set requests_allowed 1000 ;#review + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set vals [dict get $argd values] + set multis [dict get $argd multis] + set maxresults [dict get $opts -MAXRESULTS] + set initial_pagelimit [dict get $opts -limit] + set opts [dict remove $opts -MAXRESULTS] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val + } else { + foreach v $val { + lappend nextopts $opt $v + } + } + } + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + + if {$maxresults == -1} { + set maxresults $initial_pagelimit + } + if {$maxresults < $initial_pagelimit} { + punk::netbox::man::system::dupkeylist_setfirst nextopts -limit $maxresults + } + set to_go [expr {$maxresults - [llength $resultlist]}] + while {$urlnext ne "null"} { + if {$urlnext ne ""} { + set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext] + if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} { + punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go + } + #sync to -limit,-offset from the url's limit, offset values + punk::netbox::man::system::optionlistvar_sync_from_urlparams nextopts $urlnext_params + } + puts "-->next:$urlnext nextopts:$nextopts vals:$vals" + set resultd [punk::netbox::dcim::devices_list $token {*}$nextopts -RETURN dict {*}$vals] + set urlnext [dict get $resultd next] + set batch [dict get $resultd results] + lappend resultlist {*}$batch + + set to_go [expr {$maxresults - [llength $resultlist]}] + if {$to_go <= 0} {break} + incr requests_allowed -1 + if {$requests_allowed < 1} {break} + } + if {$outer_return in {table tableobject}} { + package require textblock + set t [textblock::list_as_table -return tableobject -colheaders {id device cluster primary_ip tenant site platform status comments}] + foreach dev $resultlist { + + if {[dict exists $dev cluster id]} { + set cluster "[dict get $dev cluster id]: [dict get $dev cluster name]" + } else { + set cluster [dict get $dev cluster] + } + if {[dict exists $dev primary_ip id]} { + set primary_ip "[dict get $dev primary_ip id]: [dict get $dev primary_ip address]" + } else { + set primary_ip [dict get $dev primary_ip] + } + if {[dict exists $dev tenant id]} { + set tenant "[dict get $dev tenant id]: [dict get $dev tenant slug]" + } else { + set tenant [dict get $dev tenant] ;#probably null + } + if {[dict exists $dev site id]} { + set site "[dict get $dev site id]: [dict get $dev site name]" + } else { + set site [dict get $dev site] ;#probably null + } + if {[dict exists $dev platform id]} { + set platform "[dict get $dev platform id]: [dict get $dev platform name]" + } else { + set platform [dict get $dev platform] ;#probably null + } + + set r [::list\ + [dict get $dev id]\ + [dict get $dev name]\ + $cluster\ + $primary_ip\ + $tenant\ + $site\ + $platform\ + [dict get $dev status value]\ + [dict get $dev comments]\ + ] + $t add_row $r + } + } + switch -- $outer_return { + table { + set result [$t print] + $t destroy + return $result + } + tableobject { + return $t + } + } + return $resultlist + #return [showdict $resultd] + } + } + +} tcl::namespace::eval punk::netbox::man::prefixes { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -1549,6 +1694,8 @@ namespace eval ::punk::args::register { ::punk::netbox::man::virtualization::virtual-machines\ ::punk::netbox::man::extras\ ::punk::netbox::man::extras::tags\ + ::punk::netbox::man::dcim\ + ::punk::netbox::man::dcim::devices\ } # ----------------------------------------------------------------------------- diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm index e56da520..96f506b5 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm @@ -52,7 +52,10 @@ if {[package provide punk::libunknown] eq ""} { if {$libunknown ne ""} { uplevel 1 [list source $libunknown] if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} { - puts "error initialising punk::libunknown\n$errM" + puts stderr "error initialising punk::libunknown during punk::repl package load of script [info script]" + puts stderr "sourcing from: $libunknown" + puts stderr "tcl::tm::list: [tcl::tm::list]" + puts stderr $errM } } }} @@ -2854,7 +2857,7 @@ namespace eval repl { if {$libunknown ne ""} { uplevel 1 [list source $libunknown] if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} { - puts "repl::init problem - error initialising punk::libunknown\n$errM" + puts "repl::init problem - error initialising punk::libunknown\n from '$libunknown'\n err $errM" } #package require punk::lib #puts [punk::libunknown::package_query snit] @@ -3593,7 +3596,9 @@ namespace eval repl { if {$libunknown ne ""} { uplevel 1 [list ::source $libunknown] if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { - puts "error initialising punk::libunknown\n$errM" + puts stderr "error initialising punk::libunknown\n from: '$libunknown'" + puts stderr "tcl::tm::list: [tcl::tm::list]" + puts stderr "error: $errM" } } }} diff --git a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.1.tm b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.1.tm index 7b1098f3..8e59cf0b 100644 --- a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.2.1.tm @@ -18,16 +18,19 @@ tcl::namespace::eval shellfilter::log { proc disable {} { variable is_enabled set is_enabled 0 - proc ::shellfilter::log::open {tag settingsdict} {} - proc ::shellfilter::log::write {tag msg} {} - proc ::shellfilter::log::write_sync {tag msg} {} - proc ::shellfilter::log::close {tag} {} + proc ::shellfilter::log::open {tag settingsdict} {} + proc ::shellfilter::log::write {tag msg} {} + proc ::shellfilter::log::write_sync {tag msg} {} + proc ::shellfilter::log::close {tag} {} } proc enable {} { variable is_enabled set is_enabled 1 #'tag' is an identifier for the log source. + #(well.. really it's a common *target* of file and/or syslog host:port which can be written to from any thread that uses the tag) + #the terminology here is kinda ratshit. + # each tag will use it's own thread to write to the configured log target proc ::shellfilter::log::open {tag {settingsdict {}}} { upvar ::shellfilter::sources sourcelist @@ -43,7 +46,7 @@ tcl::namespace::eval shellfilter::log { lappend sourcelist $tag } - #note new_worker + #review new_worker/assign_worker? set worker_tid [shellthread::manager::new_worker $tag $settingsdict] #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" return $worker_tid @@ -138,6 +141,7 @@ namespace eval shellfilter::pipe { chan configure $worker_chan -buffering [dict get $settingsdict -buffering] chan configure $program_chan -buffering [dict get $settingsdict -buffering] + #review chan configure $program_chan -blocking 0 chan configure $worker_chan -blocking 0 set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] @@ -1758,7 +1762,7 @@ namespace eval shellfilter::stack { dict set transform_record -obj $obj dict set transform_record -note "insert_transform-with-aside" lappend stack $transform_record - #add back poplist *except* the one we transferred into -aside (if we were able) + # add back poplist *except* the one we transferred into -aside (if we were able) foreach p [lrange $poplist $put_aside end] { set t [dict get $p -transform] set tsettings [dict get $p -settings] @@ -2639,7 +2643,12 @@ namespace eval shellfilter { ::shellfilter::log::write $debugname " waitvar '$waitvar'" } lassign [chan pipe] rderr wrerr - chan configure $wrerr -blocking 0 + + #--------------- + #JMN 2025 + # e.g cannot run ansible cmdline tools if non-blocking + #chan configure $wrerr -blocking 0 + #------------------ set custom_stderr "" set lastitem [lindex $commandlist end] @@ -2824,7 +2833,8 @@ namespace eval shellfilter { #chan configure $inchan -buffering none -blocking 1 ;#test - chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok + #chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok + chan configure $inchan -buffering $inbuffering chan configure $errchan -buffering $errbuffering @@ -3176,6 +3186,8 @@ namespace eval shellfilter { #set newbytes [encoding convertto utf-16 $stringrep] #puts -nonewline $outchan $newbytes puts -nonewline $outchan $outchunk + #jmn test 2025 + flush $outchan } } diff --git a/src/vfs/_vfscommon.vfs/modules/shellthread-1.6.2.tm b/src/vfs/_vfscommon.vfs/modules/shellthread-1.6.2.tm index 10daf8e3..6351fe4b 100644 --- a/src/vfs/_vfscommon.vfs/modules/shellthread-1.6.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/shellthread-1.6.2.tm @@ -21,6 +21,8 @@ namespace eval shellthread { namespace eval shellthread::worker { variable settings + variable settings_defaults + set settings_defaults [list -raw 0 -file "" -syslog "" -direction out] ;#also used for reset when worker returned to free thread list variable sysloghost_port variable sock variable logfile "" @@ -48,6 +50,7 @@ namespace eval shellthread::worker { variable sysloghost_port variable logfile variable settings + variable settings_defaults interp bgerror {} shellthread::worker::bgerror #package require overtype ;#overtype uses tcllib textutil, punk::char etc - currently too heavyweight in terms of loading time for use in threads. variable client_ids @@ -55,8 +58,7 @@ namespace eval shellthread::worker { lappend client_ids $tidclient set ts_start_micros $start_m - set defaults [list -raw 0 -file "" -syslog "" -direction out] - set settings [dict merge $defaults $settingsdict] + set settings [dict merge $settings_defaults $settingsdict] set syslog [dict get $settings -syslog] if {[string length $syslog]} { @@ -111,7 +113,9 @@ namespace eval shellthread::worker { error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" } set inpipe $readchan - chan configure $readchan -blocking 0 + + #JMN 2025 + #chan configure $readchan -blocking 0 set waitvar ::shellthread::worker::wait($inpipe,[clock micros]) #tcl::chan::fifo2 based pipe seems slower to establish events upon than Memchan @@ -483,13 +487,28 @@ namespace eval shellthread::manager { } if {[dict exists $workers $sourcetag]} { - set winfo [dict get $workers $sourcetag] - if {[dict get $winfo tid] ne "noop" && [thread::exists [dict get $winfo tid]]} { - #add our client-info to existing worker thread - dict lappend winfo list_client_tids $tidclient - dict set workers $sourcetag $winfo ;#writeback - return [dict get $winfo tid] - } + set winfo [dict get $workers $sourcetag] + if {[dict get $winfo tid] ne "noop" && [thread::exists [dict get $winfo tid]]} { + # add our client-info to existing worker thread + set existing_settings [get_tag_config $sourcetag] + if {$settingsdict eq $existing_settings} { + #same settings - share the worker + dict lappend winfo list_client_tids $tidclient + dict set workers $sourcetag $winfo ;#writeback + return [dict get $winfo tid] + } elseif {$existing_settings eq {-raw 0 -file {} -syslog {} -direction out}} { + #review - magic dict seems brittle - shouldn't hard code here.??? + dict lappend winfo list_client_tids $tidclient + dict set workers $sourcetag $winfo ;#writeback + return [dict get $winfo tid] + } else { + set emsg "shellthread::manager::new_worker error: tag $sourcetag already has a worker with a different configuration\n" + append emsg "existing: $existing_settings\n" + append emsg "attempted: $settingsdict\n" + append emsg "workers info: $winfo" + error $emsg + } + } } #noop fake worker for empty syslog and empty file @@ -508,7 +527,9 @@ namespace eval shellthread::manager { if {[llength $free_threads]} { #todo - re-use from tail - as most likely to have been doing similar work?? review - set free_threads [lassign $free_threads tidworker] + #set free_threads [lassign $free_threads tidworker] + set tidworker [lpop free_threads 0] + #todo - keep track of real ts_start of free threads... kill when too old set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype [dict get $settingsdict -workertype]] #puts stderr "shellfilter::new_worker Re-using free worker thread: $tidworker with tag $sourcetag" @@ -641,7 +662,7 @@ namespace eval shellthread::manager { proc unsubscribe {sourcetaglist} { variable workers #workers structure example: - #[list sourcetag1 [list tid list_client_tids ] ts_start ts_end_list {}] + #[list sourcetag1 [list tid list_client_tids ts_start ts_end_list {} workertype message|pipe]] variable free_threads set mytid [thread::id] ;#caller of shellthread::manager::xxx is the client thread @@ -684,6 +705,9 @@ namespace eval shellthread::manager { foreach workertid $subscriberless_workers { if {$workertid ni $shuttingdown_workers} { if {$workertid ni $free_threads && $workertid ne "noop"} { + #JMN + thread::send $workertid {set ::shellthread::worker::settings $::shellthread::worker::settings_defaults} + #todo - log freeing up of thread lappend free_threads $workertid } } @@ -704,6 +728,16 @@ namespace eval shellthread::manager { return $taginfo_list } + proc get_tag_config {tag} { + #review + variable workers + if {![dict exists $workers $tag]} { + error "shellthread::manager::get_tag_config error no existing tag $tag" + } + set workertid [dict get $workers $tag tid] + set conf [thread::send $workertid {set ::shellthread::worker::settings}] + } + #finalisation proc shutdown_free_threads {{timeout 2500}} { variable free_threads diff --git a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.8.tm b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.8.tm new file mode 100644 index 00000000..e1be4767 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.8.tm @@ -0,0 +1,9489 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application tomlish 1.1.8 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin tomlish_module_tomlish 0 1.1.8] +#[copyright "2024"] +#[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] +#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] +#[require tomlish] +#[keywords module parsing toml configuration] +#[description] +#[para] tomlish is an intermediate representation of toml data in a tree structure (tagged lists representing type information) +#[para] The design goals are for tomlish to be whitespace and comment preserving ie byte-for byte preservation during roundtrips from toml to tomlish and back to toml +#[para] The tomlish representation can then be converted to a Tcl dict structure or to other formats such as json, +#[para] although these other formats are generally unlikely to retain whitespace or comments +#[para] The other formats also won't preserve roundtripability e.g \t and a literal tab coming from a toml file will be indistinguishable. +#[para] A further goal is to allow at least a useful subset of in-place editing operations which also preserve whitespace and comments. +#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions +#[para] The API for editing (tomldoc object?) may require explicit setting of type if accessing an existing key +#[para] e.g setting a key that already exists and is a different type (especially if nested structure such as a table or array) +#[para] will need a -type option (-force ?) to force overriding with another type such as an int. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of tomlish +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by tomlish +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::stack +package require logger + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {struct::stack}] + +#limit ourselves to clear, destroy, peek, pop, push, rotate, or size (e.g v 1.3 does not implement 'get') + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish { + namespace export {[a-z]*}; # Convention: export all lowercase + variable types + + #*** !doctools + #[subsection {Namespace tomlish}] + #[para] Core API functions for tomlish + #[list_begin definitions] + + #default interp recursionlimit of 1000 is insufficient to pass 1000 deep nested structures as in certain toml tests. + #e.g https://github.com/iarna/toml-spec-tests/tree/latest/values + #1000 seems deep for a 'configuration' format - but toml sometimes used for other serialisation purposes. + #todo - review + set existing_recursionlimit [interp recursionlimit {}] + if {$existing_recursionlimit < 5000} { + interp recursionlimit {} 5000 + } + + #IDEAS: + # since get_toml produces tomlish with whitespace/comments intact: + # tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace + # - setKey (set leaf only to value) how to specify type? -type option? - whole array vs index into arrays and further nested objects? - option for raw toml additions? + # - separate addKey?? + # - deleteKey (delete leaf) + # - deleteTable (delete table - if only has leaves? - option to delete with child tables?) + # - set/add Table? - position in doc based on existing tables/subtables? + + #The tomlish intermediate representation allows things such as sorting the toml document by table name or other re-ordering of tables - + # because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. + #The same goes for the first newline following a keyval e.g x=1 \ny=2\n\n + #The newline is part of the keyval structure so makes reordering easier + #example from_toml "a=1\nb=2\n\n\n" + # 0 = TOMLISH + # 1 = KEY a = {INT 1} {NEWLINE lf} + # 2 = NEWLINE lf + # 3 = KEY b = {INT 2} {NEWLINE lf} + # 4 = NEWLINE lf + # 5 = NEWLINE lf + + #This reordering idea is complicated by the nature of tablearrays - especially as a table header references last tablearrayname, + # and duplicate table headers are allowed in that context. + #e.g + #[[fruits]] + # name="apple" + # [fruits.metadata] + # id=1 + # + #[unrelated1] + # + #[[fruits]] + # name="pear" + # + #[unrelated2] + # silly="ordering" + # + #[fruits.metadata] + #id=2 + #The TABLEARRAY record can't be completely selfcontained on the default parsing mechanism - because it is legal (though not recommended) to have unrelated tables in between. + #If we were to 'insert' later related records (such as the 2nd [fruits.metadata] above) into the TABLEARRAY structure - then, even though it might produce 'nicer' toml, + # we would lose roundtripability toml->tomlish->toml + # ----------------------------------------------------- + #REVIEW + #todo - some sort of 'normalize'/'grouping' function on tomlish that at least makes records self-contained, and perhaps then (optionally) reorders resulting records sensibly. + #such a function on the tomlish may work - although it would be unwise to duplicate the validation aspects of dict::from_tomlish + #The most practical way might be to use dict::from_tomlish followed by from_dict - but that would lose comment info and formatting. + #In the above example - The decision by the toml author to put [unrelated1] between related tablearrays should be respected, + #but the positioning of [unrelated2] between a tablearray and one of its contained tables is suspect. + #Both [fruits.metadata] table records should theoretically be added as children to their corresponding [[fruits]] tablearray record in the tomlish. (just as their name keys are) + # ----------------------------------------------------- + + + + #ARRAY is analogous to a Tcl list + #TABLE is analogous to a Tcl dict + #WS = inline whitespace + #KEY = bare key and value + #DQKEY = double quoted key and value + #SQKEY = single quoted key and value + #ITABLE = inline table (*can* be anonymous table) + # inline table values immediately create a table with the opening brace + # inline tables are fully defined between their braces, as are dotted-key subtables defined within + # No additional subtables or arrays of tables may be defined within an inline table after the ending brace - they must be entirely self-contained + + set tags [list TOMLISH BOM ARRAY TABLE ITABLE TABLEARRAY WS NEWLINE COMMENT DOTTEDKEY KEY DQKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL] + #DDDD + lappend tags {*}[list\ + DATETIME\ + DATETIME-LOCAL\ + DATE-LOCAL\ + TIME-LOCAL\ + ] + + #removed - ANONTABLE + #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) + #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) + #todo - configurable - allow empty string for 'unlimited' + set min_int -9223372036854775808 ;#-2^63 + set max_int +9223372036854775807 ;#2^63-1 + + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] tomlish '$txt'" + puts stderr $msg + } + logger::initNamespace ::tomlish + foreach lvl [logger::levels] { + interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl + log::logproc $lvl tomlish_log_$lvl + } + + + proc tags {} { + return $::tomlish::tags + } + + proc get_dottedkey_info {dottedkeyrecord} { + set key_hierarchy [list] + set key_hierarchy_raw [list] + if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { + error "tomlish::get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" + } + set compoundkeylist [lindex $dottedkeyrecord 1] + set expect_sep 0 + foreach part $compoundkeylist { + set parttag [lindex $part 0] + if {$parttag eq "WS"} { + continue + } + if {$expect_sep} { + if {$parttag ne "DOTSEP"} { + error "DOTTEDKEY missing dot separator between parts. '$dottedkeyrecord'" + } + set expect_sep 0 + } else { + set val [lindex $part 1] + switch -exact -- $parttag { + KEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw $val + } + DQKEY { + #REVIEW unescape or not? + #JJJJ + lappend key_hierarchy [::tomlish::utils::unescape_string $val] + lappend key_hierarchy_raw \"$val\" + } + SQKEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw "'$val'" + } + default { + error "tomlish::get_dottedkey_info DOTTED key unexpected part '$parttag' - ensure dot separator is between key parts. '$compoundkeylist'" + } + } + set expect_sep 1 + } + } + return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] + } + + #helper function for tomlish::dict::from_tomlish + proc _get_keyval_value {keyval_element} { + #e.g + #DOTTEDKEY {{KEY a} {WS { }}} = {WS { }} {ARRAY {INT 1} SEP {ITABLE {DOTTEDKEY {{KEY x}} = {INT 1} SEP} {DOTTEDKEY {{KEY y}} = {INT 2}}}} + + log::notice ">>> _get_keyval_value from '$keyval_element'<<<" + #find the value (or 2 values if space separated datetime - and stitch back into one) + # 3 is the earliest index at which the value could occur (depending on whitespace) + if {[lindex $keyval_element 2] ne "="} { + error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured { = } list\n $keyval_element" + } + + #review + if {[uplevel 1 [list info exists tablenames_info]]} { + upvar tablenames_info tablenames_info + } else { + set tablenames_info [dict create] ;#keys are @@ paths {@@parenttable @@arrayable @@etc} corresponding to parenttable.arraytable[].etc + #value is a dict with keys such as ttype, tdefined + } + set sublist [lrange $keyval_element 3 end] ;# rhs of = + + set values [list] + set value_posns [list] + set posn 0 + foreach sub $sublist { + #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 - TIME-TZ - TABLE - ARRAY - ITABLE { + lappend values $sub + lappend value_posns $posn + } + DOTTEDKEY { + #we should never see DOTTEDKEY as a toplevel element on RHS + #sanity check in case manually manipulated tomlish - or something went very wrong + set msg "tomlish::_get_keyval_value Unexpected toplevel value element DOTTEDKEY after =" + return -code error -errorcode {TOMLISH SYNTAX UNEXPECTEDDOTTEDKEYRHS} $msg + } + WS - NEWLINE - COMMENT {} + SEP {} + default { + set msg "tomlish::_get_keyval_value Unexpected toplevel value element [lindex $sub 0] after =" + return -code error -errorcode {TOMLISH SYNTAX UNEXPECTED} $msg + } + } + incr posn + } + switch -- [llength $values] { + 0 { + error "tomlish Failed to find value element in KEY. '$keyval_element'" + } + 1 { + lassign [lindex $values 0] type value + } + 2 { + #we generally expect a single 'value' item on RHS of = + #(ignoring WS,NEWLINE,SEP + #(either a simple type, or a container which has multiple values inside) + #exception for space separated datetime which is two toplevel values + + #validate than exactly single space was between the two values + lassign $value_posns p1 p2 + if {$p2 != $p1 +2} { + #sanity check + #can probably only get here through manual manipulation of the tomlish list to an unprocessable form + error "tomlish KEY appears to have more than one part - but not separated by whitespace - invalid '$keyval_element'" + } + set between_token [lindex $sublist $p1+1] + if {[lindex $between_token 1] ne " "} { + error "tomlish KEY in 2 parts is not separated by a single space - cannot consider for datetime '$keyval_element'" + } + 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 {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 + } 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}" + } + default { + error "tomlish Found multiple value elements in KEY, expected one. (or 2 for space-separated datetime) '$keyval_element'" + } + } + 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 + set result [list type $type value $value] + } + STRING - STRINGPART { + #JJJ + #!!! review + #set result [list type $type value [::tomlish::utils::unescape_string $value]] + set result [list type $type value $value] + } + LITERAL - LITERALPART { + #REVIEW + set result [list type $type value $value] + } + TABLE { + #invalid? + error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" + } + ITABLE { + #This one should not be returned as a type value structure! + # + set prev_tablenames_info $tablenames_info + set tablenames_info [dict create] + set result [::tomlish::dict::from_tomlish [ list [lindex $values 0] ]] + set sub_tablenames_info $tablenames_info + set tablenames_info $prev_tablenames_info + } + ARRAY { + #we need to recurse to get the corresponding dict for the contained item(s) + #pass in the whole [lindex $values 0] (type val) - not just the $value! + set prev_tablenames_info $tablenames_info + set tablenames_info [dict create] + set result [list type $type value [ ::tomlish::dict::from_tomlish [ list [lindex $values 0] ] ]] + set sub_tablenames_info $tablenames_info + set tablenames_info $prev_tablenames_info + } + MULTISTRING - MULTILITERAL { + #review - mapping these to STRING might make some conversions harder? + #if we keep the MULTI - we know we have to look for newlines for example when converting to json + #without specific types we'd have to check every STRING - and lose info about how best to map chars within it + set result [list type $type value [ ::tomlish::dict::from_tomlish [ list [lindex $values 0] ] ]] + } + default { + error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" + } + } + return [dict create result $result tablenames_info $sub_tablenames_info] + } + + + proc to_dict {tomlish {returnextra 0}} { + tomlish::dict::from_tomlish $tomlish $returnextra + } + + + + proc _from_dictval_tomltype {parents tablestack keys typeval} { + set type [dict get $typeval type] + set val [dict get $typeval value] + #These are the restricted sets of typed used in the tomlish::dict representation + #They are a subset of the types in tomlish: data types plus ARRAY, arranged in a dictionary form. + #The container types: ITABLE, TABLE, TABLEARRAY are not used as they are represented as dictionary keys and ARRAY items. + #The WS, COMMENT, and NEWLINE elements are also unrepresented in the dict structure. + switch -- $type { + ARRAY { + set subitems [list] + foreach item $val { + lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP + } + if {[lindex $subitems end] eq "SEP"} { + set subitems [lrange $subitems 0 end-1] + } + return [list ARRAY {*}$subitems] + } + ITABLE { + error "not applicable" + if {$val eq ""} { + return ITABLE + } else { + return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] + } + } + STRING { + #JSJS + #if our dict came from json - we have already decided what type of STRING/LITERAL etc to use when building the dict + + #do not validate like this - important that eg json val\\ue -> dict val\ue -> tomlish/toml val\\ue + #see toml-tests + #if {![tomlish::utils::rawstring_is_valid_tomlstring $val]} { + # #todo? + # return -code error -errorcode {TOML SYNTAX INVALIDSTRING} "Unescaped controls in string or invalid escapes" + #} + return [list STRING [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val]] + } + MULTISTRING { + #value is a raw string that isn't encoded as tomlish + #create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format + #We need to convert controls in $val to escape sequences - except for newlines + # + #consider an *option* to reformat for long lines? (perhaps overcomplex - byte equiv - but may fold in ugly places) + #we could use a line-length limit to decide when to put in a "line ending backslash" + #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW + # + #TODO + #set tomlpart "x=\"\"\"\\\n" ;#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] + #e.g if val = " etc\nblah" + #TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } + #lindex 1 3 is the MULTISTRING tomlish list + return [lindex $tomlish 1 3] + } + MULTILITERAL { + #MLL string can contain newlines - but still no control chars + #todo - validate - e.g val can't contain more than 2 squotes in a row + if {[string first ''' $val] >=0} { + set msg "_from_dictval_tomltype error: more than 2 single quotes in a row found in MULTILITERAL - cannot encode dict to TOML-VALID TOMLISH" + return -code error -errorcode {TOML SYNTAX INVALIDLITERAL} $msg + } + + #rawstring_is_valid_multiliteral - allow newlines as lf or crlf - but not bare cr + if {![tomlish::utils::rawstring_is_valid_multiliteral $val]} { + return -code error -errorcode {TOML SYNTAX INVALIDMULTILITERAL} "Controls other than tab or newlines found in multiliteral" + } + + set tomlpart "x='''\n" + append tomlpart $val ''' + set tomlish [tomlish::from_toml $tomlpart] + return [lindex $tomlish 1 3] + } + LITERAL { + #from v1.0 spec - "Control characters other than tab are not permitted in a literal string" + #(This rules out raw ANSI SGR - which is somewhat restrictive - but perhaps justified for a config format + # as copy-pasting ansi to a config value is probably not always wise, and it's not something that can be + # easily input via a text editor. ANSI can go in Basic strings using the \e escape if that's accepted v1.1?) + #we could choose to change the type to another format here when encountering invalid chars - but that seems + #like too much magic. We elect to error out and require the dict to have valid data for the types it specifies. + if {[string first ' $val] >=0} { + set msg "_from_dictval_tomltype error: single quote found in LITERAL - cannot encode dict to TOML-VALID TOMLISH" + return -code error -errorcode {TOML SYNTAX INVALIDLITERAL} $msg + } + #JJJJ + if {![tomlish::utils::rawstring_is_valid_literal $val]} { + #has controls other than tab + #todo - squote? + return -code error -errorcode {TOML SYNTAX INVALIDLITERAL} "Controls other than tab found in literal" + } + return [list LITERAL $val] + } + INT { + if {![::tomlish::utils::is_int $val]} { + error "_from_dictval_tomltype error: bad INT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list INT $val] + } + FLOAT { + if {![::tomlish::utils::is_float $val]} { + error "_from_dictval_tomltype error: bad FLOAT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list FLOAT $val] + } + default { + if {$type ni [::tomlish::tags]} { + error "_from_dictval_tomltype error: Unrecognised typename '$type' in {type value } - cannot encode dict to TOML-VALID TOMLISH" + } + return [list $type $val] + } + } + } + + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + set K_PART [tomlish::dict::classify_rawkey $k] ;#get [list SQKEY ] + #puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" + #puts stderr "---tablestack: $tablestack---" + set result [list] + set lastparent [lindex $parents end] + if {$lastparent in [list "" do_inline]} { + if {[tomlish::dict::is_typeval $vinfo]} { + set type [dict get $vinfo type] + #treat ITABLE differently? + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} + } else { + 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] + + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + + if {$lastparent eq "do_inline"} { + set result [list DOTTEDKEY [list $K_PART] =] + set records [list ITABLE] + } else { + set tname [tomlish::dict::join_and_quote_rawkey_list [list $k]] + set result [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $k]] + set records [list] + } + + + + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + dict for {vk vv} $vinfo { + set VK_PART [tomlish::dict::classify_rawkey $vk] ;#get [list SQKEY ] + #(SQKEY & DQKEY do not have the enclosing quotes in their returned val) + #if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + # set VK_PART [list SQKEY $vk] + #} else { + # set VK_PART [list KEY $vk] + #} + if {[tomlish::dict::is_typeval $vv]} { + #type x value y + #REVIEW - we could detect if value is an array of objects, + #and depending on parent context - emit a series of TABLEARRAY records instead of a DOTTEDKEY record containing an ARRAY of objects + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] + } else { + if {$vv eq ""} { + #experimental + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + ::tomlish::log::notice "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" + #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] + + #we can't just join normalized keys - need keys with appropriate quotes and escapes + #set tname [join [list {*}$keys $vk] .] ;#WRONG + set tq [tomlish::dict::join_and_quote_rawkey_list [list {*}$keys $vk]] + + + ##wrong? results in TABLE within TABLE record?? todo pop? + #set record [list TABLE $tq {NEWLINE lf}] + #set tablestack [list {*}$tablestack [list T $vk]] + + #REVIEW!!! + + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + + } else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + } + } else { + if { 0 } { + #experiment.. sort of getting there. + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + ::tomlish::log::notice "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" + set tq [tomlish::dict::join_and_quote_rawkey_list [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + + #review - todo? + set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] + lappend record {*}$dottedkey_value + + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + } + if {$dictidx != $lastidx} { + #lappend record SEP + if {$lastparent eq "do_inline"} { + lappend record SEP + } else { + lappend record {NEWLINE lf} + } + } + if {[llength $record]} { + lappend records $record + } + incr dictidx + } + if {$lastparent eq "do_inline"} { + lappend result $records {NEWLINE lf} + } else { + lappend result {*}$records {NEWLINE lf} + } + } else { + if {$lastparent eq "do_inline"} { + lappend result DOTTEDKEY [list $K_PART] = ITABLE {NEWLINE lf} + } else { + set tname [tomlish::dict::join_and_quote_rawkey_list [list $k]] + #REVIEW + lappend result TABLE $tname {NEWLINE lf} + } + } + } + } else { + #lastparent is not toplevel "" or "do_inline" + if {[tomlish::dict::is_typeval $vinfo]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result {*}$sublist + } else { + if {$lastparent eq "TABLE"} { + #review + dict for {vk vv} $vinfo { + set VK_PART [tomlish::dict::classify_rawkey $vk] ;#get [list SQKEY ] + set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] + lappend result [list DOTTEDKEY [list $VK_PART] = $dottedkey_value {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 lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + set sub [list] + #REVIEW + #set result $lastparent ;#e.g sets ITABLE + set result ITABLE + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + dict for {vk vv} $vinfo { + set VK_PART [tomlish::dict::classify_rawkey $vk] ;#get [list SQKEY ] + if {[tomlish::dict::is_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART] = $sublist] + } else { + if {$vv eq ""} { + #can't just uninline at this level + #we need a better method to query main dict for uninlinability at each level + # (including what's been inlined already) + #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + # puts stderr "_from_dictval uninline2 KEY $keys" + # set tname [tomlish::dict::join_and_quote_rawkey_list [list {*}$keys $vk]] + # set record [list TABLE $tname {NEWLINE lf}] + # set tablestack [list {*}$tablestack [list T $vk]] + #} else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + #} + } else { + #set sub [_from_dictval ITABLE $vk $vv] + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + #set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + if {$dictidx != $lastidx} { + lappend record SEP + } + lappend result $record + incr dictidx + } + } else { + #e.g x=[{}] + log::debug "---> _from_dictval empty ITABLE x-1" + #lappend result DOTTEDKEY [list $K_PART] = ITABLE ;#wrong + lappend result ITABLE + } + } + } + } + return $result + } + + + proc from_dict {d} { + #consider: + # t1={a=1,b=2} + # x = 1 + + # from_dict gives us: t1 {a {type INT value 1} b {type INT value 2}} x {type INT value 1} + + #If we represent t1 as an expanded table we get + # [t1] + # a=1 + # b=2 + # x=1 + # --- which is incorrect - as x was a toplevel key like t1! + #This issue doesn't occur if x is itself an inline table + # t1={a=1,b=2} + # x= {no="problem"} + # + # (or if we were to reorder x to come before t1) + + #ie the order of the dict elements influences how the toml can be represented. + + #As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} + #Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, + #which is unpreferred here. + + #A possible solution: + #scan the top level to see if all (trailing) elements are themselves dicts + # (ie not of form {type XXX value yyy}) + # + # A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements + #ie we don't need to force do_inline if all the 'simple' keys are before any compound keys + + #set root_has_values 0 + #approach 1) - the naive approach - forces inline when not always necessary + #dict for {k v} $d { + # if {[llength $v] == 4 && [lindex $v 0] eq "type"} { + # set root_has_values 1 + # break + # } + #} + + + #approach 2) - track the position of last {type x value y} in the dictionary built by dict::from_tomlish + # - still not perfect. Inlines dotted tables unnecessarily + #This means from_dict doesn't produce output optimal for human editing. + set last_simple [tomlish::dict::last_tomltype_posn $d] + + + ## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values + #Any keys that are themselves tables - will need to be represented inline + #to avoid reordering, or incorrect assignment of plain values to the wrong table. + + ## set parent "" + #all toplevel keys in the dict structure can represent subtables. + #we are free to use {[tablename]\n} syntax for toplevel elements. + + + set tomlish [list TOMLISH] + set dictposn 0 + set tablestack [list [list T root]] ;#todo + dict for {t tinfo} $d { + if {$last_simple > $dictposn} { + set parents [list do_inline] + } else { + set parents [list ""] + } + set keys [list $t] + #review - where to make decision on + # DOTTEDKEY containing array of objs + #vs + # list of TABLEARRAY records + #At least for the top + set trecord [_from_dictval $parents $tablestack $keys $tinfo] + lappend tomlish $trecord + incr dictposn + } + return $tomlish + } + + proc typedjson_to_toml {json} { + #*** !doctools + #[call [fun typedjson_to_toml] [arg json]] + #[para] + + set tomlish [::tomlish::from_dict_from_typedjson $json] + lappend tomlish [list NEWLINE lf] + set toml [::tomlish::to_toml $tomlish] + } + + set json1 {{ "a": {"type": "integer", "value": "42"}}} + set json2 {{ + "a": {"type": "integer", "value": "42"}, + "b": {"type": "string", "value": "test"} + }} + set json3 { +{ + "best-day-ever": {"type": "datetime", "value": "1987-07-05T17:45:00Z"}, + "numtheory": { + "boring": {"type": "bool", "value": "false"}, + "perfection": [ + {"type": "integer", "value": "6"}, + {"type": "integer", "value": "28"}, + {"type": "integer", "value": "496"} + ] + } +} + } + + set json4 { +{ + "best-day-ever": {"type": "datetime", "value": "1987-07-05T17:45:00Z"}, + "numtheory": { + "boring": {"type": "bool", "value": "false"}, + "perfection": [ + {"type": "integer", "value": "6"}, + {"type": "integer", "value": "28"}, + {"type": "integer", "value": "496"} + ] + }, + "emptyobj": {}, + "emptyarray": [] +} + } + + set json5 { +{ + "a": { + " x ": {}, + "b.c": {}, + "d.e": {}, + "b": { + "c": {} + } + } +} + } + + #surrogate pair face emoji + set json6 { +{ + "surrogatepair": {"type": "string", "value": "\uD83D\uDE10"} +} + } + + + set json7 { +{ + "escapes": {"type": "string", "value": "val\\ue"} +} + } + + + proc from_dict_from_typedjson {json} { + set d [tomlish::dict::from_typedjson $json] + tomlish::from_dict $d ;#return tomlish + } + + + proc toml_to_typedjson {toml} { + set tomlish [::tomlish::from_toml $toml] + set d [tomlish::dict::from_tomlish $tomlish] + #full validation only occurs by re-encoding dict to tomlish + set test [tomlish::from_dict $d] + + set h [tomlish::typedhuddle::from_dict $d] + #huddle jsondump $h + tomlish::huddle::jsondumpraw $h + } + + #proc get_json {tomlish} { + # package require fish::json + # set d [::tomlish::dict::from_tomlish $tomlish] + + # #return [::tomlish::dict_to_json $d] + # return [fish::json::from "struct" $d] + #} + + #return a Tcl list of tomlish tokens + #i.e get a standard list of all the toml terms in string $s + #where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. + #(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) + # ---------------------------------------------------------------------------------------------- + # NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! + # e.g we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- + #Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. + # (e.g perhaps a toml editor to highlight violations for fixing) + # A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. + # e.g dicts or an object oriented structure + #Note also - *no* escapes in quoted strings are processed. This is up to the datastructure stage + #e.g dict::from_tomlish will substitute \r \n \uHHHH \UHHHHHHH etc + #This is important for tomlish to maintain the ability to perform competely lossless round-trips from toml to tomlish and back to toml. + # (which is handy for testing as well as editing some part of the structure with absolutely no effect on other parts of the document) + #If we were to unescape a tab character for example + # - we have no way of knowing if it was originally specified as \t \u0009 or \U00000009 or directly as a tab character. + # For this reason, we also do absolutely no line-ending transformations based on platform. + # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + + proc from_toml {args} { + + namespace upvar ::tomlish::parse s s + set s [join $args \n] + namespace upvar ::tomlish::parse i i + set i 0 ;#index into s + + namespace upvar ::tomlish::parse is_parsing is_parsing + set is_parsing 1 + + if {[info command ::tomlish::parse::spacestack] eq "::tomlish::parse::spacestack"} { + tomlish::parse::spacestack destroy + } + struct::stack ::tomlish::parse::spacestack + + namespace upvar ::tomlish::parse last_space_action last_space_action + namespace upvar ::tomlish::parse last_space_type last_space_type + + namespace upvar ::tomlish::parse tok tok + set tok "" + + namespace upvar ::tomlish::parse type type + namespace upvar ::tomlish::parse tokenType tokenType + ::tomlish::parse::set_tokenType "" + namespace upvar ::tomlish::parse tokenType_list tokenType_list + set tokenType [list] ;#Flat (un-nested) list of tokentypes found + + namespace upvar ::tomlish::parse lastChar lastChar + set lastChar "" + + + set result "" + namespace upvar ::tomlish::parse nest nest + set nest 0 + + namespace upvar ::tomlish::parse v v ;#array keyed on nest level + + + set v(0) {TOMLISH} + array set s0 [list] ;#whitespace data to go in {SPACE {}} element. + set parentlevel 0 + + + namespace upvar ::tomlish::parse state state + + namespace upvar ::tomlish::parse braceCount braceCount + set barceCount 0 + namespace upvar ::tomlish::parse bracketCount bracketCount + set bracketCount 0 + + set sep 0 + set r 1 + namespace upvar ::tomlish::parse token_waiting token_waiting + set token_waiting [dict create] ;#if ::tok finds a *complete* second token during a run, it will put the 2nd one here to be returned by the next call. + + + + set state "table-space" + ::tomlish::parse::spacestack push {type space state table-space} + namespace upvar ::tomlish::parse linenum linenum;#'line number' of input data. (incremented for each literal linefeed - but not escaped ones in data) + set linenum 1 + + set ::tomlish::parse::state_list [list] + try { + while {$r} { + set r [::tomlish::parse::tok] + #puts stdout "got tok: '$tok' while parsing string '$s' " + set next_tokenType_known 0 ;#whether we begin a new token here based on what terminated the token result of 'tok' + + + #puts "got token: '$tok' tokenType='$tokenType'. while v($nest) = [set v($nest)]" + #puts "-->tok: $tok tokenType='$tokenType'" + set prevstate $state + set transition_info [::tomlish::parse::goNextState $tokenType $tok $state] + #review goNextState could perform more than one space_action + set space_action [dict get $transition_info space_action] + set newstate [dict get $transition_info newstate] ;#use of 'newstate' vs 'state' makes code clearer below + + if {[tcl::string::match "err-*" $state]} { + ::tomlish::log::warn "---- State error in state $prevstate for tokenType: $tokenType token value: $tok. $state aborting parse. [tomlish::parse::report_line]" + lappend v(0) [list ERROR tokentype $tokenType state $prevstate to $state leveldata [set v($nest)]] + return $v(0) + } + # --------------------------------------------------------- + #NOTE there may already be a token_waiting at this point + #set_token_waiting can raise an error here, + # in which case the space_action branch needs to be rewritten to handle the existing token_waiting + # --------------------------------------------------------- + + if {$space_action eq "pop"} { + #pop_trigger_tokens: newline tablename endarray endinlinetable + #note a token is a pop trigger depending on context. e.g first newline during keyval is a pop trigger. + set parentlevel [expr {$nest -1}] + set do_append_to_parent 1 ;#most tokens will leave this alone - but some like tentative_accum_squote need to do their own append + switch -exact -- $tokenType { + tentative_accum_squote { + #should only apply within a multiliteral + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the xxx-squote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + #assert prevstate always trailing-squote-space + #dev guardrail - remove? assertion lib? + switch -exact -- $prevstate { + trailing-squote-space { + } + default { + error "--- unexpected popped due to tentative_accum_squote but came from state '$prevstate' should have been trailing-squote-space" + } + } + switch -- $tok { + ' { + tomlish::parse::set_token_waiting type single_squote value $tok complete 1 startindex [expr {$i -1}] + } + '' { + #review - we should perhaps return double_squote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_squote value "" complete 1 startindex [expr {$i - 2}] + } + ''' { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 3}] + } + '''' { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left squote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]'" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "'"] + } + MULTILITERAL { + #empty + lappend v($parentlevel) [list LITERALPART "'"] + } + default { + error "--- don't know how to integrate extra trailing squote with data $v($parentlevel)" + } + } + } + ''''' { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 squotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]''" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "''"] + } + MULTILITERAL { + lappend v($parentlevel) [list LITERALPART "''"] + } + default { + error "--- don't know how to integrate extra trailing 2 squotes with data $v($parentlevel)" + } + } + } + } + } + triple_squote { + #presumably popping multiliteral-space + ::tomlish::log::debug "---- triple_squote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTILITERAL { + lappend merged $part + } + LITERALPART { + if {$lasttype eq "LITERALPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_squote unhandled part type [lindex $part 0] unable to merge leveldata: $v($nest)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + tentative_accum_dquote { + #should only apply within a multistring + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the trailing-dquote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + #assert prevstate always trailing-dquote-space + #dev guardrail - remove? assertion lib? + switch -exact -- $prevstate { + trailing-dquote-space { + } + default { + error "--- unexpected popped due to tentative_accum_dquote but came from state '$prevstate' should have been trailing-dquote-space" + } + } + switch -- $tok { + {"} { + tomlish::parse::set_token_waiting type single_dquote value $tok complete 1 startindex [expr {$i -1}] + } + {""} { + #review - we should perhaps return double_dquote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_dquote value "" complete 1 startindex [expr {$i - 2}] + } + {"""} { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i - 3}] + } + {""""} { + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left dquote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + STRINGPART { + set newval "[lindex $lastpart 1]\"" + set parentdata $v($parentlevel) + lset parentdata end [list STRINGPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE - CONT - WS { + lappend v($parentlevel) [list STRINGPART {"}] + } + MULTISTRING { + #empty + lappend v($parentlevel) [list STRINGPART {"}] + } + default { + error "--- don't know how to integrate extra trailing dquote with data $v($parentlevel)" + } + } + } + {"""""} { + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 dquotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + STRINGPART { + set newval "[lindex $lastpart 1]\"\"" + set parentdata $v($parentlevel) + lset parentdata end [list STRINGPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE - CONT - WS { + lappend v($parentlevel) [list STRINGPART {""}] + } + MULTISTRING { + lappend v($parentlevel) [list STRINGPART {""}] + } + default { + error "--- don't know how to integrate extra trailing 2 dquotes with data $v($parentlevel)" + } + } + } + } + } + triple_dquote { + #presumably popping multistring-space + ::tomlish::log::debug "---- triple_dquote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTISTRING { + lappend merged $part + } + STRINGPART { + if {$lasttype eq "STRINGPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + CONT - WS { + lappend merged $part + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_dquote unhandled part type [lindex $part 0] unable to merge leveldata: $v($nest)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + equal { + #pop caused by = + switch -exact -- $prevstate { + dottedkey-space { + tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + dottedkey-space-tail { + #experiment? + tomlish::log::debug "---- equal ending dottedkey-space-tail for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + } + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + tablename { + #note: a tablename only 'pops' if we are greater than zero + error "---- tablename pop should already have been handled as special case zeropoppushspace in goNextState" + } + tablearrayname { + #!review - tablearrayname different to tablename regarding push/pop? + #note: a tablename only 'pops' if we are greater than zero + error "---- tablearrayname pop should already have been handled as special case zeropoppushspace in goNextState" + } + endarray { + #nothing to do here. + } + comma { + #comma for inline table will pop the keyvalue space + lappend v($nest) "SEP" + } + endinlinetable { + ::tomlish::log::debug "---- endinlinetable for last_space_action pop" + } + default { + error "---- unexpected tokenType '$tokenType' for last_space_action 'pop'" + } + } + if {$do_append_to_parent} { + #e.g tentative_accum_squote does it's own appends as necessary - so won't get here + lappend v($parentlevel) [set v($nest)] + } + + incr nest -1 + + } elseif {$last_space_action eq "push"} { + set prevnest $nest + incr nest 1 + set v($nest) [list] + # push_trigger_tokens: barekey dquotedkey startinlinetable startarray tablename tablearrayname + + + switch -exact -- $tokenType { + tentative_trigger_squote - tentative_trigger_dquote { + #### this startok will always be tentative_accum_squote/tentative_accum_dquote starting with one accumulated squote/dquote + if {[dict exists $transition_info starttok] && [dict get $transition_info starttok] ne ""} { + lassign [dict get $transition_info starttok] starttok_type starttok_val + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType $starttok_type + set tok $starttok_val + } + } + single_squote { + #JMN - REVIEW + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + triple_squote { + ::tomlish::log::debug "---- push trigger tokenType triple_squote" + set v($nest) [list MULTILITERAL] ;#container for NEWLINE,LITERALPART + } + squotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + triple_dquote { + set v($nest) [list MULTISTRING] ;#container for NEWLINE,STRINGPART,CONT + } + dquotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + barekey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + set waiting [tomlish::parse::get_token_waiting] + if {[llength $waiting]} { + set i [dict get $waiting startindex] + tomlish::parse::clear_token_waiting + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } else { + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + } + tablename { + #note: we do not use the output of tablename_trim to produce a tablename for storage in the tomlish list! + #The tomlish list is intended to preserve all whitespace (and comments) - so a roundtrip from toml file to tomlish + # back to toml file will be identical. + #It is up to the datastructure stage to normalize and interpret tomlish for programmatic access. + # we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, + # so we can raise an error at this point rather than create a tomlish list with obviously invalid table names from + # a structural perspective. + + #todo - review! It's arguable that we should not do any validation here, and just store even incorrect raw tablenames, + # so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the + # tomlish list? + + #set trimtable [tablename_trim $tok] + #::tomlish::log::debug "---- trimmed (but not normalized) tablename: '$trimtable'" + set v($nest) [list TABLE $tok] ;#$tok is the *raw* table name + #note also that equivalent tablenames may have different toml representations even after being trimmed! + #e.g ["x\t\t"] & ["x "] (tab escapes vs literals) + #These will show as above in the tomlish list, but should normalize to the same tablename when used as keys by the datastructure stage. + } + tablearrayname { + #set trimtable [tablename_trim $tok] + #::tomlish::log::debug "---- trimmed (but not normalized) tablearrayname: '$trimtable'" + set v($nest) [list TABLEARRAY $tok] ;#$tok is the *raw* tablearray name + } + startarray { + set v($nest) [list ARRAY] ;#$tok is just the opening bracket - don't output. + } + startinlinetable { + set v($nest) [list ITABLE] ;#$tok is just the opening curly brace - don't output. + } + default { + error "---- push trigger tokenType '$tokenType' not yet implemented" + } + } + + } else { + #no space level change + switch -exact -- $tokenType { + squotedkey { + #puts "---- squotedkey in state $prevstate (no space level change)" + lappend v($nest) [list SQKEY $tok] + } + dquotedkey { + #puts "---- dquotedkey in state $prevstate (no space level change)" + lappend v($nest) [list DQKEY $tok] + } + barekey { + lappend v($nest) [list KEY $tok] + } + dotsep { + lappend v($nest) [list DOTSEP] + } + starttablename { + #$tok is triggered by the opening bracket and sends nothing to output + } + starttablearrayname { + #$tok is triggered by the double opening brackets and sends nothing to output + } + tablename - tablenamearray { + error "---- did not expect 'tablename/tablearrayname' without space level change (no space level change)" + #set v($nest) [list TABLE $tok] + } + endtablename - endtablearrayname { + #no output into the tomlish list for this token + } + startinlinetable { + puts stderr "---- decode::toml error. did not expect startinlinetable without space level change (no space level change)" + } + single_dquote { + switch -exact -- $newstate { + string-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "string" + set tok "" + } + dquoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "dquotedkey" + set tok "" + } + multistring-space { + lappend v($nest) [list STRINGPART {"}] + #may need to be joined on pop if there are neighbouring STRINGPARTS + } + default { + error "---- single_dquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + double_dquote { + #leading extra quotes - test: toml_multistring_startquote2 + switch -exact -- $prevstate { + itable-keyval-value-expected - keyval-value-expected { + puts stderr "tomlish::decode::toml double_dquote TEST" + #empty string + lappend v($nest) [list STRINGPART ""] + } + multistring-space { + #multistring-space to multistring-space + lappend v($nest) [list STRINGPART {""}] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + + } + single_squote { + switch -exact -- $newstate { + literal-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "literal" + set tok "" + } + squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + multiliteral-space { + #false alarm squote returned from tentative_accum_squote pop + ::tomlish::log::debug "---- adding lone squote to own LITERALPART nextstate: $newstate (no space level change)" + #(single squote - not terminating space) + lappend v($nest) [list LITERALPART '] + #may need to be joined on pop if there are neighbouring LITERALPARTs + } + default { + error "---- single_squote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + double_squote { + switch -exact -- $prevstate { + keyval-value-expected { + lappend v($nest) [list LITERAL ""] + } + multiliteral-space { + #multiliteral-space to multiliteral-space + lappend v($nest) [list LITERALPART ''] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + enddquote { + #nothing to do? + set tok "" + } + endsquote { + set tok "" + } + string { + #JJJJ + set tok [tomlish::from_Bstring $tok] + lappend v($nest) [list STRING $tok] ;#directly wrapped in dquotes + } + literal { + lappend v($nest) [list LITERAL $tok] ;#directly wrapped in squotes + } + multistring { + #review + #JJJJ ? + lappend v($nest) [list MULTISTRING $tok] + } + stringpart { + #JJJJ + set tok [tomlish::from_Bstring $tok] + lappend v($nest) [list STRINGPART $tok] ;#will not get wrapped in dquotes directly + } + multiliteral { + lappend v($nest) [LIST MULTILITERAL $tok] + } + literalpart { + lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly + } + untyped_value { + #would be better termed unclassified_value + #we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. + unset -nocomplain tag + if {$tok in {true false}} { + set tag BOOL + } else { + if {[::tomlish::utils::is_int $tok]} { + set tag INT + } else { + 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 + #or other integer format issue such as repeated underscores + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. (looks close to being an int. Formatting or range issue?) [tomlish::parse::report_line] (no space level change)" + } else { + #DDDD + if {[::tomlish::utils::is_float $tok]} { + set tag FLOAT + } 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_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_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_time-local $tp]} { + set tag DATETIME-LOCAL + } else { + 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)" + } + } + } + } + #assert either tag is set, or we errored out. + lappend v($nest) [list $tag $tok] + + } + comment { + #puts stdout "----- comment token returned '$tok'------" + #JJJJ + set tok [tomlish::from_comment $tok] + lappend v($nest) [list COMMENT "$tok"] + } + equal { + #we append '=' to the nest so that any surrounding whitespace is retained. + lappend v($nest) = + } + comma { + lappend v($nest) SEP + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + whitespace { + lappend v($nest) [list WS $tok] + } + continuation { + lappend v($nest) CONT + } + bom { + lappend v($nest) BOM + } + eof { + #ok - nothing more to add to the tomlish list. + #!todo - check previous tokens are complete/valid? + } + default { + error "--- unknown tokenType '$tokenType' during state $prevstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + + if {!$next_tokenType_known} { + ::tomlish::log::notice "---- tomlish::decode::toml - current tokenType:$tokenType Next token type not known" + ::tomlish::parse::set_tokenType "" + set tok "" + } + + if {$state eq "end-state"} { + break + } + + + } + + #while {$nest > 0} { + # lappend v([expr {$nest -1}]) [set v($nest)] + # incr nest -1 + #} + while {[::tomlish::parse::spacestack size] > 1} { + ::tomlish::parse::spacestack pop + lappend v([expr {$nest -1}]) [set v($nest)] + incr nest -1 + + #set parent [spacestack peek] ;#the level being appended to + #lassign $parent type state + #if {$type eq "space"} { + # + #} elseif {$type eq "buffer"} { + # lappend v([expr {$nest -1}]) {*}[set v($nest)] + #} else { + # error "invalid spacestack item: $parent" + #} + } + + } finally { + set is_parsing 0 + } + return $v(0) + } + + #toml dquoted string to tomlish STRING + # - only allow specified escape sequences + # - allow any unicode except those that must be escaped: dquote, bsl, and control chars(except tab) + proc from_Bstring {bstr} { + #JJJJ + if {[catch { + tomlish::utils::unescape_string $bstr + } errM]} { + return -code error -errorcode {TOML SYNTAX INVALIDESCAPE} "tomlish::from_Bstring toml Bstring contains invalid escape sequence\n$errM" ;#review + } + #assert: all escapes are now valid + + if {[regexp {[\u0000-\u0008\u000A-\u001F\u007f]} $bstr]} { + set msg "tomlish::from_Bstring toml Bstring contains controls that must be escaped" + return -code error -errorcode {TOML SYNTAX BSTRINGUNESCAPEDCONTROLS} $msg ;#review + } + return $bstr + } + #validate toml comment + # - disallow controls that must be escaped + #from spec: + # "Control characters other than tab (U+0000 to U+0008, U+000A to U+001F, U+007F) are not permitted in comments." + proc from_comment {comment} { + if {[regexp {[\u0000-\u0008\u000A-\u001F\u007f]} $comment]} { + set msg "tomlish::from_comment toml comment contains controls that must be escaped" + return -code error -errorcode {TOML SYNTAX COMMENTUNESCAPEDCONTROLS} $msg ;#review + } + return $comment + } + + + #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] + #todo - what happens when less source elements than in existing array? ie sourcedata is empty. + # + 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 $arrchild_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 ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +namespace eval tomlish::build { + #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness + # take a value of the appropriate type and wrap as a tomlish tagged item + proc STRING {s} { + return [list STRING [::tomlish::utils::rawstring_to_Bstring_with_escaped_controls $s]] + } + proc LITERAL {litstring} { + error todo + } + + proc INT {i} { + #whole numbers, may be prefixed with a + or - + #Leading zeros are not allowed + #Hex,octal binary forms are allowed (toml 1.0) + #We will error out on encountering commas, as commas are interpreted differently depending on locale (and don't seem to be supported in the toml spec anyway) + #!todo - Tcl can handle bignums - bigger than a 64bit signed long as specified in toml. + # - We should probably raise an error for number larger than this and suggest the user supply it as a string? + if {[tcl::string::last , $i] > -1} { + error "Unable to interpret '$i' as an integer. Use underscores if you need a thousands separator [::tomlish::parse::report_line]" + } + if {![::tomlish::utils::int_validchars $i]} { + error "Unable to interpret '$i' as an integer. Only 0-9 + 1 _ characters are acceptable. [::tomlish::parse::report_line]" + } + + if {[::tomlish::utils::is_int $i]} { + return [list INT $i] + } else { + error "'$i' is not a valid integer as per the Toml spec. [::tomlish::parse::report_line]" + } + + } + + proc FLOAT {f} { + #convert any non-lower case variants of special values to lowercase for Toml + if {[::tcl::string::tolower $f] in {nan +nan -nan inf +inf -inf}} { + return [list FLOAT [tcl::string::tolower $f]] + } + if {[::tomlish::utils::is_float $f]} { + return [list FLOAT $f] + } else { + error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" + } + } + + proc DATETIME {str} { + if {[::tomlish::utils::is_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]" + } + } + proc DATETIME-LOCAL {str} { + error "build::DATETIME-LOCAL todo" + } + + proc BOOLEAN {b} { + #convert any Tcl-acceptable boolean to boolean as accepted by toml - lower case true/false + if {![tcl::string::is boolean -strict $b]} { + error "Unable to convert '$b' to Toml boolean true|false. [::tomlish::parse::report_line]" + } else { + if {$b && 1} { + return [::list BOOL true] + } else { + return [::list BOOL false] + } + } + } + + #REVIEW + #Take tablename followed by + # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} + # (accept also key value {STRING }) + # b) simple 2-element tcl lists being name & *simple* value pairs for which basic heuristics will be used to determine types + proc _table {name args} { + set pairs [list] + foreach t $args { + if {[llength $t] == 4} { + if {[tcl::string::tolower [lindex $t 0]] ne "key" || [tcl::string::tolower [lindex $t 2]] ni "= value"} { + error "Only items tagged as KEY = currently accepted as name-value pairs for table command" + } + lassign $t _k keystr _eq valuepart + if {[llength $valuepart] != 2} { + error "supplied value must be typed. e.g {INT 1} or {STRING test}" + } + lappend pairs [list KEY $keystr = $valuepart] + } elseif {[llength $t] == 2} { + #!todo - type heuristics + lassign $t n v + lappend pairs [list KEY $n = [list STRING $v]] + } else { + error "'KEY = { toml but + # the first newline is not part of the data. + # we elect instead to maintain a basic LITERALPART that must not contain newlines.. + # and to compose MULTILITERAL of multiple NEWLINE LITERALPART parts, + #with the datastructure representation dropping the first newline (if immediately following opening delim) when building the value. + set literal "" + foreach part [lrange $item 1 end] { + append literal [::tomlish::encode::tomlish [list $part] $nextcontext] + } + append toml '''$literal''' + } + INT - + BOOL - + FLOAT - + DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL { + #DDDD + append toml [lindex $item 1] + } + INCOMPLETE { + error "cannot process tomlish term tagged as INCOMPLETE" + } + COMMENT { + append toml "#[lindex $item 1]" + } + BOM { + #Byte Order Mark may appear at beginning of a file. Needs to be preserved. + append toml "\uFEFF" + } + default { + error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command." + } + } + + } + return $toml + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::encode ---}] +} +#fish toml from tomlish + +#(encode tomlish as toml) +interp alias {} tomlish::to_toml {} tomlish::encode::tomlish + +# + + +namespace eval tomlish::decode { + #*** !doctools + #[subsection {Namespace tomlish::decode}] + #[para] + #[list_begin definitions] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::decode ---}] +} +#decode toml to tomlish +#interp alias {} tomlish::from_toml {} tomlish::decode::toml + +namespace eval tomlish::utils { + #*** !doctools + #[subsection {Namespace tomlish::utils}] + #[para] + #[list_begin definitions] + + #------------------------------------------------------------------------------ + # 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 + #note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes + proc tok_in_quotedpart {tok} { + set sLen [tcl::string::length $tok] + set quote_type "" + set had_slash 0 + for {set i 0} {$i < $sLen} {incr i} { + set c [tcl::string::index $tok $i] + if {$quote_type eq ""} { + if {$had_slash} { + #don't enter quote mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + set quote_type dq + } + sq { + set quote_type sq + } + bsl { + set had_slash 1 + } + } + } + } else { + if {$had_slash} { + #don't leave quoted mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + if {$quote_type eq "dq"} { + set quote_type "" + } + } + sq { + if {$quote_type eq "sq"} { + set quote_type "" + } + } + bsl { + set had_slash 1 + } + } + } + } + } + return $quote_type ;#dq | sq + } + + proc hex_escape_info {slashx} { + set exp {^\\x([0-9a-fA-F]{2}$)} + if {[regexp $exp $slashx match hex]} { + return [list ok [list char [subst -nocommand -novariable $slashx]]] + } else { + return [list err [list reason "Supplied string not of the form \\xHH where H in \[0-9a-fA-F\]"]] + } + } + proc unicode_escape_info {slashu} { + #!todo + # validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and + # is a valid 'unicode scalar value' (any Unicode code point except high-surrogate and low-surrogate code points) + # ie integers in the range 0 to D7FF16 and E00016 to 10FFFF16 inclusive + #expr {(($x >= 0) && ($x <= 0xD7FF16)) || (($x >= 0xE00016) && ($x <= 0x10FFFF16))} + if {[tcl::string::match {\\u*} $slashu]} { + set exp {^\\u([0-9a-fA-F]{4}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %4x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } + } else { + return [list err [list reason "Supplied string not of the form \\uHHHH where H in \[0-9a-fA-F\]"]] + } + } elseif {[tcl::string::match {\\U*} $slashu]} { + set exp {^\\U([0-9a-fA-F]{8}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %8x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + if {(($dec >= 0) && ($dec <= 0xD7FF16)) || (($dec >= 0xE00016) && ($dec <= 0x10FFFF16))} { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } else { + return [list err [list reason "$slashu is not within the 'unicode scalar value' ranges 0 to 0xD7FF16 or 0xE00016 to 0x10FFFF16"]] + } + } + } else { + return [list err [list reason "Supplied string not of the form \\UHHHHHHHH where H in \[0-9a-fA-F\]"]] + } + } else { + return [list err [list reason "Supplied string did not start with \\u or \\U" ]] + } + + } + + #Note that unicode characters don't *have* to be escaped. + #So if we provide a function named 'escape_string', the name implies the inverse of unescape_string which unescapes unicode \u \U values. + #- an inverse of unescape_string would encode all unicode chars unnecessarily. + #- as toml accepts a compact escape sequence for common chars such as tab,backspace,linefeed etc but also allows the full form \u009 etc + #- escape_string and unescape_string would not be reliably roundtrippable inverses anyway. + #REVIEW - provide it anyway? When would it be desirable to use? + + variable Bstring_control_map [dict create] + dict set Bstring_control_map \b {\b} + dict set Bstring_control_map \n {\n} + dict set Bstring_control_map \r {\r} + dict set Bstring_control_map \" {\"} + dict set Bstring_control_map \x1b {\e} ;#In spec it's included in the list of 'must be escaped', as well as the 'convenience' escapes - so we make it go both ways. + dict set Bstring_control_map \\ "\\\\" + + #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ + #for a Bstring (Basic string) tab is explicitly mentioned as not being one that must be escaped. + #8 = \b - already in list. + #built the remainder whilst checking for entries already hardcoded above -in case more are added to the hardcoded list + for {set cdec 0} {$cdec <= 7} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Bstring_control_map $char]} { + dict set Bstring_control_map $char \\u$hhhh + } + } + for {set cdec [expr {0x0A}]} {$cdec <= 0x1F} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Bstring_control_map $char]} { + dict set Bstring_control_map $char \\u$hhhh + } + } + # \u007F = 127 + dict set Bstring_control_map [format %c 127] \\u007F + + # ------------------------------------------------------------------ + variable Literal_control_map [dict create] + #controls other than tab + for {set cdec 0} {$cdec <= 8} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Literal_control_map $char]} { + dict set Literal_control_map $char \\u$hhhh + } + } + for {set cdec [expr {0x0A}]} {$cdec <= 0x1F} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Literal_control_map $char]} { + dict set Literal_control_map $char \\u$hhhh + } + } + # \u007F = 127 + dict set Literal_control_map [format %c 127] \\u007F + # ------------------------------------------------------------------ + variable Multiliteral_control_map + set Multiliteral_control_map [dict remove $Literal_control_map \n] + + variable String_control_map + set String_control_map [dict remove $Literal_control_map \\] + + + variable MultiBstring_totoml_map + #'minimally' escaped sequences of double quotes. + #e.g {""\"""\"} vs {\"\"\"\"\"} + #This produces easier to read toml - and in many cases may be more likely to match original format when roundtripped from dict datastructure + # REVIEW - should this be configurable? + set MultiBstring_totoml_map [dict remove $Bstring_control_map {"} \r \n] + dict set MultiBstring_totoml_map {"""} {""\"} ;#" editor hack: commented quote for dumb syntax highlighers + + #Note the inclusion of backslash in the list of controls makes this non idempotent - subsequent runs would keep encoding the backslashes! + #escape only those chars that must be escaped in a Bstring (e.g not tab which can be literal or escaped) + #for example - can be used by from_dict to produce valid Bstring data for a tomlish record + proc rawstring_to_Bstring_with_escaped_controls {str} { + #for the well known chars that have compact escape sequences allowed by toml - we choose that form over the full \u form. + #we'll use a string map with an explicit list rather than algorithmic at runtime + # - the string map is probably more performant than splitting a string, especially if it's large + + upvar ::tomlish::utils::Bstring_control_map map + + return [string map $map $str] + } + proc rawstring_to_MultiBstring_with_escaped_controls {str} { + #for the well known chars that have compact escape sequences allowed by toml - we choose that form over the full \u form. + #we'll use a string map with an explicit list rather than algorithmic at runtime + # - the string map is probably more performant than splitting a string, especially if it's large + + upvar ::tomlish::utils::MultiBstring_totoml_map map + + return [string map $map $str] + } + + #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 + + #strip remaining dquotes + set dquoteless [string map [list "\"" ""] $without_escaped_dquotes] + #puts stderr "dquoteless: $dquoteless" + + #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 "\\" \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} { + #detect control chars other than tab + variable Literal_control_map + set testval [string map $Literal_control_map $str] + return [expr {$testval eq $str}] + } + proc rawstring_is_valid_multiliteral {str} { + #detect control chars other than tab + variable Multiliteral_control_map + + set teststr [string map [list \r\n ok] $str] + + set testval [string map $Multiliteral_control_map $teststr] + return [expr {$testval eq $teststr}] + } + + #review - unescape what string? Bstring vs MLBstring? + #we should be specific in the function naming here + #used by dict::from_tomlish - so part of validation? - REVIEW + proc unescape_string {str} { + #note we can't just use Tcl subst because: + # it also transforms \a (audible bell) and \v (vertical tab) which are not in the toml spec. + # it would strip out backslashes inappropriately: e.g "\j" becomes just j + # it recognizes other escapes which aren't approprite e.g octal \nnn + # it replaces \ with a single whitespace (trailing backslash) + #This means we shouldn't use 'subst' on the whole string, but instead substitute only the toml-specified escapes (\r \n \b \t \f \\ \" \uhhhh & \Uhhhhhhhh + #plus \e for \x1b? + + set buffer "" + set buffer2 "" ;#buffer for 2 hex characters following a \x + set buffer4 "" ;#buffer for 4 hex characters following a \u + set buffer8 "" ;#buffer for 8 hex characters following a \u + + set sLen [tcl::string::length $str] + + #we need to handle arbitrarily long sequences of backslashes. \\\\\ etc + set slash_active 0 + set unicode2_active 0 + set unicode4_active 0 + set unicode8_active 0 + + ::tomlish::log::debug "unescape_string. got len [string length str] str $str" + + #!todo - check for invalid data in the form of a raw carriage return (decimal 13) without following linefeed? + set i 0 + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $str [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $str $i] + #::tomlish::log::debug "unescape_string. got char $c" ;#too much? + + ##---------------------- + ##as we are 'unescaping' - should we really be testing here for existing values that should have been escaped? + ##The answer is probably no - keep this function to a single purpose - test elsewhere for raw controls. + ##this test looks incomplete anyway REVIEW + #scan $c %c n + #if {($n <= 31) && ($n != 9) && ($n != 10) && ($n != 13)} { + # #we don't expect unescaped unicode characters from 0000 to 001F - + # #*except* for raw tab (which is whitespace) and newlines + # error "unescape_string. Invalid data for a toml string. Unescaped control character (decimal $n) [::tomlish::utils::string_to_slashu $c]" + #} + ##---------------------- + + incr i ;#must incr here because we do'returns'inside the loop + if {$c eq "\\"} { + if {$slash_active} { + append buffer "\\" + set slash_active 0 + } elseif {$unicode2_active} { + error "unescape_string. unexpected case slash during unicode2 not yet handled" + } elseif {$unicode4_active} { + error "unescape_string. unexpected case slash during unicode4 not yet handled" + } elseif {$unicode8_active} { + error "unescape_string. unexpected case slash during unicode8 not yet handled" + } else { + # don't output anything (yet) + set slash_active 1 + } + } else { + if {$unicode2_active} { + if {[tcl::string::length $buffer2] < 2} { + append buffer2 $c + } + if {[tcl::string::length $buffer2] == 2} { + #we have a \xHH to test + set unicode2_active 0 + set result [tomlish::utils::hex_escape_info "\\x$buffer2"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$unicode4_active} { + if {[tcl::string::length $buffer4] < 4} { + append buffer4 $c + } + if {[tcl::string::length $buffer4] == 4} { + #we have a \uHHHH to test + set unicode4_active 0 + set result [tomlish::utils::unicode_escape_info "\\u$buffer4"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$unicode8_active} { + if {[tcl::string::length $buffer8] < 8} { + append buffer8 $c + } + if {[tcl::string::length $buffer8] == 8} { + #we have a \UHHHHHHHH to test + set unicode8_active 0 + set result [tomlish::utils::unicode_escape_info "\\U$buffer8"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$slash_active} { + set slash_active 0 + set ctest [tcl::string::map {{"} dq} $c] + switch -exact -- $ctest { + dq { + append buffer {"} + } + b - t - n - f - r { + append buffer [subst -nocommand -novariable "\\$c"] + } + e { + append buffer \x1b + } + x { + #introduced in 1.1.0 \xHH + set unicode2_active 1 + set buffer2 "" + } + u { + set unicode4_active 1 + set buffer4 "" + } + U { + set unicode8_active 1 + set buffer8 "" + } + default { + set slash_active 0 + #review - toml spec says all other escapes are reserved + #and if they are used TOML should produce an error. + #append buffer "\\$c" + set msg "Invalid escape sequence \\ followed by '$c'" + return -code error -errorcode {TOMLISH SYNTAX INVALIDESCAPE} $msg + } + } + } else { + append buffer $c + } + } + } + #puts stdout "EOF 4:$unicode4_active 8:$unicode8_active slash:$slash_active" + if {$unicode2_active} { + error "End of string reached before complete hex escape sequence \xHH" + } + if {$unicode4_active} { + error "End of string reached before complete unicode escape sequence \uHHHH" + } + if {$unicode8_active} { + error "End of string reached before complete unicode escape sequence \UHHHHHHHH" + } + if {$slash_active} { + append buffer "\\" + } + try { + encoding convertto utf-8 $buffer + } trap {} {emsg eopts} { + return -code error -errorcode {TOMLISH SYNTAX ENCODINGERROR} $emsg + } + return $buffer + } + + #This does not have to do with unicode normal forms - which it seems toml has decided against regarding use in keys (review/references?) + #This is meant for internal use regarding ensuring we match equivalent keys which may have just been specified with different string mechanisms, + #e.g squoted vs dquoted vs barekey. + proc normalize_key {rawkey} { + set c1 [tcl::string::index $rawkey 0] + set c2 [tcl::string::index $rawkey end] + if {($c1 eq "'") && ($c2 eq "'")} { + #single quoted segment. No escapes allowed within it. + set key [tcl::string::range $rawkey 1 end-1] + } elseif {($c1 eq "\"") && ($c2 eq "\"")} { + #double quoted segment. Unapply escapes. + # + set keydata [tcl::string::range $rawkey 1 end-1] ;#strip outer quotes only + #e.g key could have mix of \UXXXXXXXX escapes and unicode chars + #or mix of \t and literal tabs. + #unescape to convert all to literal versions for comparison + set key [::tomlish::utils::unescape_string $keydata] + #set key [subst -nocommands -novariables $keydata] ;#wrong. Todo - create a string escape substitution function. + } else { + set key $rawkey + } + return $key + } + + proc string_to_slashu {string} { + set rv {} + foreach c [split $string {}] { + scan $c %c cdec + if {$cdec > 65535} { + append rv {\U} [format %.8X $cdec] + } else { + append rv {\u} [format %.4X $cdec] + } + } + return $rv + } + + #'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. + #This is used for display purposes only (error msgs) + proc nonprintable_to_slashu {s} { + set res "" + foreach i [split $s ""] { + scan $i %c cdec + + set printable 0 + if {($cdec>31) && ($cdec<127)} { + set printable 1 + } + if {$printable} { + append res $i + } else { + if {$cdec > 65535} { + append res \\U[format %.8X $cdec] + } else { + append res \\u[format %.4X $cdec] + } + } + } + set res + } ;# initial version from tcl wiki RS + + proc rawstring_to_jsonstring {s} { + #like nonprintable_to_slashu + # - also escape every dquote + # - escape newlines + set res "" + foreach i [split $s ""] { + scan $i %c cdec + switch -- $cdec { + 34 { + #double quote + append res \\\" + } + 13 { + #carriage return + append res \\r + } + 8 { + append res \\b + } + 9 { + append res \\t + } + 10 { + #linefeed + append res \\n + } + 92 { + append res \\\\ + } + default { + set printable 0 + if {($cdec>31) && ($cdec<127)} { + set printable 1 + } + if {$printable} { + append res $i + } else { + if {$cdec > 65535} { + #append res $i + #append res \\U[format %.8X $cdec] ;#wrong + #append res "\\U{[format %.8x $cdec]}" ;#some variation of json? + package require punk::cesu + #e.g \U0001f610 emoticon face + #surrogate pair: \uD83D\uDE10 + set surrogatepair [punk::cesu::to_surrogatestring -format escape $i] + append res $surrogatepair + } else { + append res \\u[format %.4X $cdec] + } + } + } + } + } + set res + + } + + #check if str is valid for use as a toml bare key + #Early toml versions only allowed letters + underscore + dash + proc is_basic_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } else { + set matches [regexp -all {[a-zA-Z0-9\_\-]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters match the regexp + return 1 + } else { + return 0 + } + } + } + + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + + #test only that the characters in str are valid for the toml specified type 'integer'. + proc int_validchars1 {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_\-\+]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + #add support for hex,octal,binary 0x.. 0o.. 0b... + proc int_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_int {str} { + set matches [regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] ;#0b101 etc covered by a-f + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + + # --------------------------------------- + #check for leading zeroes in non 0x 0b 0o + #first strip any +, - or _ (just for this test) + #(but still allowing 0 -0 +0) + set check [tcl::string::map {+ "" - "" _ ""} $str] + if {([tcl::string::length $check] > 1) && ([tcl::string::index $check 0] eq "0") && ([tcl::string::index $check 1] ni {o x b})} { + return 0 + } + # --------------------------------------- + + #check +,- only occur in the first position. (excludes also +++1 etc) + if {[tcl::string::last - $str] > 0} { + return 0 + } + if {[tcl::string::last + $str] > 0} { + return 0 + } + + #------------------------------------------- + #unclear if a 'digit' includes the type specifiers x b o + #we assume the 0x 0b 0o are NOT counted as digits - as underscores here would seem + #to be likely to cause interop issues with other systems + #(e.g tcl allows 0b1_1 but not 0b_11) + #Most of this structure would be unnecessary if we could rely on string::is::integer understanding underscores (9+?) + #we still need to support earlier Tcl for now though. + + #first rule out any case with more than one underscore in a row + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_0xFF + if {[string index $utest 0] eq "_"} { + return 0 + } + if {[string range $utest 0 1] in {0x 0b 0o}} { + set testnum [string range $utest 2 end] + #spec says *non-negative* integers may *also* be expressed in hex, octal or binary + #and also explicitly states + not allowed + #presumed to mean negative not allowed. + if {[string index $str 0] in {- +}} { + return 0 + } + } else { + set testnum $utest + #exclude also things like 0_x 0___b that snuck past our prefix test + if {![string is digit -strict [string map {_ ""} $testnum]]} { + return 0 + } + #assert - only digits and underscores in testnum + #still may have underscores at each end + } + #assert testnum is now the 'digits' portion of a , 0x 0b 0o number + #(+ and - already stripped) + #It may still have chars unsuitable for its type - which will be caught by the string::is::integer test below + if {[string length $testnum] != [string length [string trim $testnum _]]} { + #had non-inner underscores in 'digit' part + return 0 + } + #assert str only has solo inner underscores (if any) between 'digits' + #------------------------------------------- + + 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 {![::tomlish::utils::string_is_integer -strict $numeric_value]} { + return 0 + } + + + + #!todo - check bounds only based on some config value + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements by default (for now) + #presumably very large numbers would have to be supplied in a toml file as strings. + #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max + #some question around implementations allowed to use lower values such as 2^31 on some systems? + if {$::tomlish::max_int ne "" && $numeric_value > $::tomlish::max_int} { + return 0 + } + if {$::tomlish::min_int ne "" && $numeric_value < $::tomlish::min_int} { + return 0 + } + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'float'. + proc float_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[eE0-9\_\-\+\.]} $str] == $numchars} { + return 1 + } else { + #only allow lower case for these special values - as per Toml 1.0 spec + if {$str ni {inf +inf -inf nan +nan -nan}} { + return 0 + } else { + return 1 + } + } + } + + #note - Tcl's string is double will return true also for the subset of float values which are integers + #This function is to determine whether it matches the Toml float concept - so requires a . or e or E + proc is_float {str} { + #vip greenlight known literals, don't test for case variations - as Toml doesn't allow (whereas Tcl allows Inf NaN etc) + if {$str in {inf +inf -inf nan +nan -nan}} { + return 1 + } + #doorcheck the basics for floatiness vs members of that rival gang - ints + if {![regexp {[.eE]} $str]} { + #could be an integer - which isn't specifically a float for Toml purposes. + return 0 + } + + + #patdown for any contraband chars + set matches [regexp -all {[eE0-9\_\-\+\.]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + + #all characters in legal range + + #A leading zero is ok, but we should disallow multiple leading zeroes (same rules as toml ints) + + #Early Toml spec also disallowed leading zeros in the exponent part(?) + #... this seems less interoperable anyway (some libraries generate leading zeroes in exponents) + #we allow leading zeros in exponents here. + + #Check for leading zeros in main part + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + set r {([0-9])*} + regexp $r $check intpart ;#intpart holds all numerals before the first .,e or E + #leading zero only if exactly one zero + if {$intpart ne "0" && [string match 0* $intpart]} { + return 0 + } + + #for floats, +,- may occur in multiple places + #e.g -2E-22 +3e34 + #!todo - check bounds ? + + #----------------------------------------- + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_" || [string index $str end] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_ + if {[string index $utest 0] eq "_"} { + return 0 + } + #----------------------------------------- + + #decimal point, if used must be surrounded by at least one digit on each side + #e.g 3.e+20 also illegal + set dposn [string first . $str] + if {$dposn > -1 } { + set d3 [string range $str $dposn-1 $dposn+1] + if {![::tomlish::utils::string_is_integer -strict [string index $d3 0]] || ![::tomlish::utils::string_is_integer -strict [string index $d3 2]]} { + return 0 + } + } + #we've already eliminated leading/trailing underscores + #now ensure each inner underscore is surrounded by digits + if {[regexp {_[^0-9]|[^0-9]_} $str]} { + return 0 + } + + #strip underscores for tcl double check so we can support < tcl 9 versions which didn't allow underscores + set check [tcl::string::map {_ ""} $str] + #string is double accepts inf nan +NaN etc. + if {![tcl::string::is double $check]} { + return 0 + } + + #All good - seems to be a toml-approved float and not an int. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'datetime'. + proc datetime_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[zZtT0-9\-\+\.:]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + + #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} { + return 0 + } + #assert now digits and colons only + set hms_cparts [split $val :] + #2 or 3 parts only are valid - check contents of each part + if {[llength $hms_cparts] == 2} { + lassign $hms_cparts hr min + if {[string length $hr] != 2 || [string length $min] != 2} { + return 0 + } + 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} { + return 0 + } + #possible for sec to be 60 - leap second RFC 3339 + if {$hr > 23 || $min > 59 || $sec > 60} { + return 0 + } + return 1 + } else { + return 0 + } + } + proc is_timepart {str} { + #validate the part after the T (or space) + #we receive only that trailing part here. + + #odt1 = 1979-05-27T07:32:00Z + #odt2 = 1979-05-27T00:32:00-07:00 + #odt3 = 1979-05-27T00:32:00.5-07:00 + #odt4 = 1979-05-27T00:32:00.999999-07:00 + + set numchars [tcl::string::length $str] + #timepart can have negative or positive offsets so - and + must be accepted + if {[regexp -all {[zZt0-9\-\+\.:]} $str] == $numchars} { + #todo + #basic check that we have leading 2dig hr and 2dig min separated by colon + if {![regexp {^[0-9]{2}:[0-9]{2}$|^[0-9]{2}:[0-9]{2}[^0-9]{1}.*$} $str]} { + #nn:nn or nn:nnX.* where X is non digit + return 0 + } + set dotparts [split $str .] + if {[llength $dotparts] ni {1 2}} { + return 0 + } + 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:??. + #check for +/- something + if {[regexp {(.*)[+-](.*)} $tail _match fraction offset]} { + if {![string is digit -strict $fraction]} { + return 0 + } + 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 + if {![string is digit -strict $tail]} { + return 0 + } + } + + } else { + #no dot (fraction of second) + if {[regexp {(.*)[+-](.*)} $str _match hms 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 { + set hms $str + set offset "" + #trim a *single* z or Z off hms if present - multiple should error later + if {[string index $hms end] in {z Z}} { + set hms [string range $hms 0 end-1] + } + } + } + #hms is allowed in toml to be hh:mm:ss or hh:mm + #validate we have hh:mm:ss or hh:mm - exactly 2 digits each + if {![_is_hms_or_hm_time $hms]} { + return 0 + } + + return 1 + } else { + return 0 + } + } + + 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} { + #todo + if {![regexp {^[0-9]{2}:[0-9]{2}$|^[0-9]{2}:[0-9]{2}:[0-9]{2}([.][0-9]+){0,1}$} $str]} { + #hh:mm or hh:mm:ss or hh:mm::ss.nnn + return 0 + } + set dotparts [split $str .] + if {[llength $dotparts] ni {1 2}} { + return 0 + } + if {[llength $dotparts] == 2} { + lassign $dotparts hms _tail + #validate tail - just fractional seconds - regex has confirmed at least one digit and only digits + #nothing todo? max length? + } else { + #no fractional seconds + set hms $str + } + if {![_is_hms_or_hm_time $hms]} { + return 0 + } + return 1 + } else { + return 0 + } + } + 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! + # (RFC 3339 allows space instead of T also - but doesn't specify it *must* be a single space) + + #toml-lint @2025-04 doesn't accept t for T or z for Z - but RFC3339 does + #toml spec doesn't clarify - we will accept + + #e.g 1979-05-27 + #e.g 1979-05-27T00:32:00Z + #e.g 1979-05-27 00:32:00-07:00 + #e.g 1979-05-27 00:32:00+10:00 + #e.g 1979-05-27 00:32:00.999999-07:00 + + #review + #minimal datetimes? + # 2024 not ok - 2024T not accepted by tomlint why? + # 02:00 ok + # 02:00:00.5 ok + # 1:00 - not ok - RFC3339 requires 2-digit hr,min,sec + + #toml-lint.com accepts 2025-01 + + if {[string length $str] < 5} { + return 0 + } + + set matches [regexp -all {[zZtT0-9\ \-\+\.:]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + if {[regexp -all {\ } $str] > 1} { + #only a single space is allowed. + return 0 + } + #If we get a space - it is only valid as a convience to represent the T separator + #we can normalize by converting to T here before more tests + set str [string map {" " T t T} $str] + #a further sanity check on T + if {[regexp -all {T} $str] > 1} { + return 0 + } + + #!todo - use full RFC 3339 parser? + #!todo - what if the value is 'time only'? + + if {[string first T $str] > -1} { + lassign [split $str T] datepart timepart + if {![is_date-local $datepart]} { + return 0 + } + if {![is_timepart $timepart]} { + return 0 + } + } else { + #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_date-local $str] || [is_time-local $str])} { + return 0 + } + } + + + #Tcl's free-form clock scan (no -format option) is deprecated + # + #if {[catch {clock scan $datepart} err]} { + # puts stderr "tcl clock scan failed err:'$err'" + # return 0 + #} + + } else { + return 0 + } + return 1 + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::utils ---}] +} + +namespace eval tomlish::parse { + #*** !doctools + #[subsection {Namespace tomlish::parse}] + #[para] + #[list_begin definitions] + + #This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases. + #The code is a pig's-nest - but it should be noted that for example trailing single double quotes in multiline strings are perhaps not so trivial to parse using more standard methods either: + # - e.g some kind of backtracking required if using an ABNF parser? + #I don't know the precise technical name for this sort of parser; probably something like "Dog's Breakfast" + #More seriously, we don't have distinct lex/parse steps - so it is basically a 'fused lexer' or 'scannerless parser' + + #It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? + + #A possible alternative more structured approach might be to use a PEG (Parsing Expression Grammar) + + + variable is_parsing 0 ;#whether we are in the middle of parsing tomlish text + + variable state + # states: + # table-space, itable-space, array-space + # array-value-expected,keyval-value-expected,itable-keyval-value-expected, keyval-syntax, + # dquoted-key, squoted-key + # string-state, literal-state, multistring... + # + # notes: + # only the -space states are also 'spaces' ie a container which is pushed/popped on the spacestack + + # + # xxx_value-expected - we also allow for leading whitespace in this state, but once a value is returned we jump to a state based on the containing space. e.g keyval-tail or array-syntax + # + #stateMatrix defines for each state, actions to take for each possible token. + #single-element actions are the name of the next state into which to transition, or a 'POPSPACE' instruction to pop a level off the spacestack and add the data to the parent container. + #dual-element actions are a push instruction and the name of the space to push on the stack. + # - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) + + # -- --- --- --- --- --- + #token/state naming guide + # -- --- --- --- --- --- + #tokens : underscore separated or bare name e.g newline, start_quote, start_squote + #private tokens: always have a leading underscore (These are private 'temporary state' tokens that are never returned as actual tokens e.g _start_squote_sequence + #states : always contain at least one dash e.g err-state, table-space + #instructions + # -- --- --- --- --- --- + + + #stateMatrix dict of elements mapping current state to next state based on returned tokens + # current-state {token-encountered next-state ... } + # where next-state can be a 1 or 2 element list. + #If 2 element - the first item is an instruction (ucase) + #If 1 element - it is either a lowercase dashed state name or an ucase instruction + #e.g {PUSHSPACE } or POPSPACE or SAMESPACE + + + #SAMESPACE - got to same space as parent without popping a level, but has it's own autotransition lookup - strange concept - review usecases + + variable stateMatrix + set stateMatrix [dict create] + #--------------------------------------------------------- + #WARNING + #The stateMatrix implementation here is currently messy. + #The code is a mixture of declarative via the stateMatrix and imperative via switch statements during PUSH/POP/SAMESPACE transitions. + #This means the state behaviour has to be reasoned about by looking at both in conjuction. + #--------------------------------------------------------- + + #xxx-space vs xxx-syntax inadequately documented - TODO + + #review - out of date? + # --------------------------------------------------------------------------------------------------------------# + # incomplete example of some state starting at table-space + # --------------------------------------------------------------------------------------------------------------# + # ( = -> keyval-value-expected) + # keyval-syntax (popped -> keyval-space -> keyval-tail) (autotransition on pop) + # keyval-space (autotransition on push ^) + # table-space (barekey^) (startdquote -> dquoted-key ^) + # --------------------------------------------------------------------------------------------------------------# + + dict set stateMatrix\ + table-space { + bom "table-space"\ + whitespace "table-space"\ + newline "table-space"\ + barekey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + squotedkey {PUSHSPACE "keyval-space" state "keyval-syntax" note ""}\ + dquotedkey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + XXXsingle_dquote "quoted-key"\ + XXXsingle_squote "squoted-key"\ + comment "table-space"\ + starttablename "tablename-state"\ + starttablearrayname "tablearrayname-state"\ + enddquote "err-state"\ + endsquote "err-state"\ + comma "err-state"\ + eof "end-state"\ + equal "err-state"\ + cr "err-lonecr"\ + } + + + + dict set stateMatrix\ + keyval-space {\ + whitespace "keyval-syntax"\ + equal "keyval-value-expected"\ + } + + # ' = ' portion of keyval + dict set stateMatrix\ + keyval-syntax {\ + whitespace "keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "keyval-value-expected"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + #### + dict set stateMatrix\ + keyval-value-expected {\ + whitespace "keyval-value-expected"\ + untyped_value {TOSTATE "keyval-untyped-sequence" note "possible datetime datepart"}\ + literal {TOSTATE "keyval-tail" note "required for empty literal at EOF"}\ + string {TOSTATE "keyval-tail" note "required for empty string at EOF"}\ + single_dquote {TOSTATE "string-state" returnstate keyval-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + single_squote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + } + #double_squote {TOSTATE "keyval-tail" note "empty literal received when double squote occurs"} + + #untyped_value sequences without intervening comma are allowed for datepart timepart + #we will produce tomlish with missing SEPS and to_dict must validate whether 2 adjacent barekeys are valid + dict set stateMatrix\ + keyval-untyped-sequence {\ + whitespace "keyval-untyped-sequence"\ + untyped_value {TOSTATE "keyval-tail"}\ + literal {TOSTATE "keyval-tail" note "required for empty literal at EOF"}\ + string {TOSTATE "keyval-tail" note "required for empty string at EOF"}\ + single_dquote {TOSTATE "string-state" returnstate keyval-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + single_squote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + #2025 - no leading-squote-space - only trailing-squote-space. + + dict set stateMatrix\ + keyval-tail {\ + whitespace "keyval-tail"\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + + #itable-space/ curly-syntax : itables + # x={y=1,} + dict set stateMatrix\ + itable-space {\ + whitespace "itable-space"\ + newline "itable-space"\ + barekey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + dquotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + endinlinetable "POPSPACE"\ + comma "err-state"\ + comment "itable-space"\ + eof "err-state"\ + } + #we don't get single_squote etc here - instead we get the resulting squotedkey token + + + # ??? review - something like this + # + # x={y =1,} + dict set stateMatrix\ + itable-keyval-syntax {\ + whitespace {TOSTATE "itable-keyval-syntax"}\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal {TOSTATE "itable-keyval-value-expected"}\ + newline "err-state"\ + eof "err-state"\ + } + + # x={y=1} + dict set stateMatrix\ + itable-keyval-space {\ + whitespace "itable-keyval-syntax"\ + equal {TOSTATE "itable-keyval-value-expected" note "required"}\ + } + + dict set stateMatrix\ + itable-keyval-value-expected {\ + whitespace "itable-keyval-value-expected"\ + untyped_value {TOSTATE "itable-val-tail" note ""}\ + single_dquote {TOSTATE "string-state" returnstate itable-val-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate itable-val-tail}\ + single_squote {TOSTATE "literal-state" returnstate itable-val-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate itable-val-tail}\ + startinlinetable {PUSHSPACE "itable-space" returnstate itable-val-tail}\ + startarray {PUSHSPACE "array-space" returnstate itable-val-tail}\ + } + #double_squote not currently generated by _start_squote_sequence - '' processed as single_squote to literal-state just like 'xxx' + # review + # double_squote {TOSTATE "itable-val-tail" note "empty literal received when double squote occurs"} + + + + # x={y=1,z="x"} + #POPSPACE is transition from itable-keyval-space to parent itable-space + dict set stateMatrix\ + itable-val-tail {\ + whitespace "itable-val-tail"\ + endinlinetable "POPSPACE"\ + comma "POPSPACE"\ + newline {TOSTATE "itable-val-tail" note "itable-space ??"}\ + comment "itable-val-tail"\ + eof "err-state"\ + } + # XXXnewline "POPSPACE" + # We shouldn't popspace on newline - as if there was no comma we need to stay in itable-val-tail + # This means the newline and subsequent whitespace, comments etc become part of the preceeding dottedkey record + #e.g + # x = { + # j=1 + # #comment within dottedkey j record + # , # comment unattached + # #comment unattached + # k=2 , #comment unattached + # l=3 #comment within l record + # , m=4 + # #comment associated with m record + # + # #still associated with m record + # } + ## - This doesn't quite correspond to what a user might expect - but seems like a consistent mechanism. + #The awkwardness is because there is no way to put in a comment that doesn't consume a trailing comma + #so we cant do: j= 1 #comment for j1 , + # and have the trailing comma recognised. + # + # To associate: j= 1, #comment for j1 + # we would need some extra processing . (not popping until next key ? extra state itable-sep-tail?) REVIEW - worth doing? + # + # The same issue occurs with multiline arrays. The most natural assumption is that a comment on same line after a comma + # is 'associated' with the previous entry. + # + # These comment issues are independent of the data dictionary being generated for conversion to json etc - as the comments don't carry through anyway, + # but are a potential oddity for manipulating the intermediate tomlish structure whilst attempting to preserve 'associated' comments + # (e.g reordering records within an itable) + #The user's intention for 'associated' isn't always clear and the specs don't really guide on this. + + + #dottedkey-space is not (currently) used within [tablename] or [[tablearrayname]] + #it is for keyval ie x.y.z = value + + #this is the state after dot + #we are expecting a complete key token or whitespace + #(initial entry to the space is by one of the keys - which will immediately go to dottedkey-space-tail) + dict set stateMatrix\ + dottedkey-space {\ + whitespace "dottedkey-space"\ + dotsep "err-state"\ + barekey "dottedkey-space-tail"\ + squotedkey "dottedkey-space-tail"\ + dquotedkey "dottedkey-space-tail"\ + newline "err-state"\ + comma "err-state"\ + comment "err-state"\ + equal "err-state"\ + } + + #dottedkeyend "POPSPACE" + #equal "POPSPACE"\ + + + #jmn 2025 + #we have 1 or more dottedkeys so far - need dotsep to add more, whitespace to maintain, equal to pop + dict set stateMatrix\ + dottedkey-space-tail {\ + whitespace "dottedkey-space-tail" + dotsep "dottedkey-space" + equal "POPSPACE"\ + eof "err-state"\ + newline "err-state"\ + } + + #-------------------------------------------------------------------------- + #scratch area + #from_toml {x=1} + # barekey tok + # table-space PUSHSPACE keyval-space state keyval-syntax + # + + + #-------------------------------------------------------------------------- + + + #REVIEW + #toml spec looks like heading towards allowing newlines within inline tables + #https://github.com/toml-lang/toml/issues/781 + + #2025 - multiline itables appear to be valid for 1.1 - which we are targeting. + #https://github.com/toml-lang/toml/blob/main/toml.md#inline-table + + #JMN2025 + #review comment "err-state" vs comment "itable-space" - see if TOML 1.1 comes out and allows comments in multiline ITABLES + #We currently allow multiline ITABLES (also with comments) in the tokenizer. + #if we want to disallow as per TOML 1.0 - we should do so when attempting to get structure? + + + #JMN REVIEW + #dict set stateMatrix\ + # array-space {\ + # whitespace "array-space"\ + # newline "array-space"\ + # untyped_value "SAMESPACE"\ + # startarray {PUSHSPACE "array-space"}\ + # endarray "POPSPACE"\ + # startinlinetable {PUSHSPACE itable-space}\ + # single_dquote "string-state"\ + # single_squote "literal-state"\ + # triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax note "seems ok 2024"}\ + # comma "array-space"\ + # comment "array-space"\ + # eof "err-state-array-space-got-eof"\ + # } + + ## array-space ## + set aspace [dict create] + dict set aspace whitespace "array-space" + dict set aspace newline "array-space" + #dict set aspace untyped_value "SAMESPACE" + dict set aspace untyped_value "array-syntax" + dict set aspace startarray {PUSHSPACE "array-space"} + dict set aspace endarray "POPSPACE" + dict set aspace single_dquote {TOSTATE "string-state" returnstate array-syntax} + dict set aspace triple_dquote {PUSHSPACE "multistring-space" returnstate array-syntax} + dict set aspace single_squote {TOSTATE "literal-state" returnstate array-syntax} + dict set aspace triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax} + dict set aspace startinlinetable {PUSHSPACE itable-space} + #dict set aspace comma "array-space" + dict set aspace comment "array-space" + dict set aspace eof "err-state-array-space-got-eof" + dict set stateMatrix array-space $aspace + + #when we pop from an inner array we get to array-syntax + #e.g {x=[[]] ??? + set tarntail [dict create] + dict set tarntail whitespace "err-state" ;#"tablearrayname-tail" ;#spec doesn't allow whitespace here + dict set tarntail newline "err-state" + dict set tarntail comment "err-state" + dict set tarntail eof "err-state" + dict set tarntail endtablename "tablearray-tail" + dict set stateMatrix tablearrayname-tail $tarntail + + #review - somewhat counterintuitive...? + # [(starttablearrayname) (endtablearrayname] + # [(starttablename) (endtablename)] + + # [[xxx]] ??? + set tartail [dict create] + dict set tartail whitespace "tablearray-tail" + dict set tartail newline "table-space" + dict set tartail comment "tablearray-tail" + dict set tartail eof "end-state" + dict set stateMatrix tablearray-tail $tartail + + + + + + + dict set stateMatrix\ + end-state {} + + set knowntokens [list] + set knownstates [list] + dict for {state transitions} $stateMatrix { + if {$state ni $knownstates} {lappend knownstates $state} + dict for {tok instructions} $transitions { + if {$tok ni $knowntokens} {lappend knowntokens $tok} + } + } + dict set stateMatrix nostate {} + foreach tok $knowntokens { + dict set stateMatrix nostate $tok "err-nostate-received-token-$tok" + } + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #purpose - debugging? remove? + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #build a list of 'push triggers' from the stateMatrix + # ie tokens which can push a new space onto spacestack + set push_trigger_tokens [list] + tcl::dict::for {s transitions} $stateMatrix { + tcl::dict::for {token transition_to} $transitions { + set instruction [lindex $transition_to 0] + switch -exact -- $instruction { + PUSHSPACE - zeropoppushspace { + if {$token ni $push_trigger_tokens} { + lappend push_trigger_tokens $token + } + } + } + } + } + ::tomlish::log::debug "push_trigger_tokens: $push_trigger_tokens" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + + #This seems hacky... (deprecate in favour of explicit arguments to the instructions in stateMatrix?) + #spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE + + #mainly for the -space states: + #redirect to another state $c based on a state transition from $whatever to $b + # e.g "string {array-space array-syntax}" means when transitioning from string to array-space, jump to array-syntax instead. + #this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' + + #use dict set to add values so we can easily add/remove/comment lines + + #Push to, next + #default first states when we push to these spaces + variable spacePushTransitions [dict create] + dict set spacePushTransitions keyval-space keyval-syntax + dict set spacePushTransitions itable-keyval-space itable-keyval-syntax + dict set spacePushTransitions array-space array-space + dict set spacePushTransitions table-space tablename-state + #dict set spacePushTransitions #itable-space itable-space + + #Pop to, next + variable spacePopTransitions [dict create] + dict set spacePopTransitions array-space array-syntax + + + #itable-keyval-space itable-val-tail + #review + #we pop to keyval-space from dottedkey-space or from keyval-value-expected? we don't always want to go to keyval-tail + #leave it out and make the POPSPACE caller explicitly specify it + #keyval-space keyval-tail + + variable spaceSameTransitions [dict create] + #JMN test + #dict set spaceSameTransitions array-space array-syntax + + #itable-keyval-space itable-val-tail + + + variable state_list ;#reset every tomlish::decode::toml + + namespace export tomlish toml + namespace ensemble create + + #goNextState has various side-effects e.g pushes and pops spacestack + #REVIEW - setting nest and v elements here is ugly + #todo - make neater, more single-purpose? + proc goNextState {tokentype tok currentstate} { + variable state + variable nest + variable v + + set prevstate $currentstate + + + variable spacePopTransitions + variable spacePushTransitions + variable spaceSameTransitions + + variable last_space_action "none" + variable last_space_type "none" + variable state_list + + set result "" + set starttok "" + + if {[dict exists $::tomlish::parse::stateMatrix $currentstate $tokentype]} { + set transition_to [dict get $::tomlish::parse::stateMatrix $currentstate $tokentype] + ::tomlish::log::debug "--->> goNextState tokentype:$tokentype tok:$tok currentstate:$currentstate : transition_to = $transition_to" + switch -exact -- [lindex $transition_to 0] { + POPSPACE { + set popfromspace_info [spacestack peek] + set popfromspace_state [dict get $popfromspace_info state] + spacestack pop + set parent_info [spacestack peek] + set type [dict get $parent_info type] + set parentspace [dict get $parent_info state] + + set last_space_action "pop" + set last_space_type $type + + if {[dict exists $parent_info returnstate]} { + set next [dict get $parent_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace redirected to stored returnstate $next <<---" + } else { + ### + #review - do away with spacePopTransitions - which although useful to provide a default.. + # - involve error-prone configurations distant to the main state transition configuration in stateMatrix + if {[dict exists $::tomlish::parse::spacePopTransitions $parentspace]} { + set next [dict get $::tomlish::parse::spacePopTransitions $parentspace] + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace redirected state to $next (spacePopTransitions)<<---" + } else { + set next $parentspace + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace<<---" + } + } + set result $next + } + SAMESPACE { + set currentspace_info [spacestack peek] + ::tomlish::log::debug "--->> SAMESPACE got current space entry: $currentspace_info <<<<<" + set type [dict get $currentspace_info type] + set currentspace [dict get $currentspace_info state] + + if {[dict exists $currentspace_info returnstate]} { + set next [dict get $currentspace_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected to stored returnstate $next" + } else { + if {[dict exists $::tomlish::parse::spaceSameTransitions $currentspace]} { + set next [dict get $::tomlish::parse::spaceSameTransitions $currentspace] + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected state to $next (spaceSameTransitions)" + } else { + set next $currentspace + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace" + } + } + set result $next + } + zeropoppushspace { + if {$nest > 0} { + #pop back down to the root level (table-space) + spacestack pop + set parentinfo [spacestack peek] + set type [dict get $parentinfo type] + set target [dict get $parentinfo state] + + set last_space_action "pop" + set last_space_type $type + + #----- + #standard pop + set parentlevel [expr {$nest -1}] + lappend v($parentlevel) [set v($nest)] + incr nest -1 + #----- + } + #re-entrancy + + #set next [list PUSHSPACE [lindex $transition_to 1]] + set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 + ::tomlish::log::debug "--->> zeropoppushspace goNextState RECURSE. calling goNextState $nexttokentype $currentstate" + set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] + set result [dict get $transition_info newstate] + } + PUSHSPACE { + set original_target [dict get $transition_to PUSHSPACE] + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + if {[dict exists $transition_to starttok]} { + set starttok [dict get $transition_to starttok] + } + spacestack push [dict create type space state $original_target] + + set last_space_action "push" + set last_space_type "space" + + if {[dict exists $transition_to state]} { + #an explicit state in the pushed space was requested in the stateMatrix - override the spacePushTransition (spacePushTransitions can be deprecated if we require explicitness?) + set next [dict get $transition_to state] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next by explicit 'state' entry" + } else { + #puts $::tomlish::parse::spacePushTransitions + if {[dict exists $::tomlish::parse::spacePushTransitions $original_target]} { + set next [dict get $::tomlish::parse::spacePushTransitions $original_target] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next (spacePushTransitions) " + } else { + set next $original_target + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target" + } + } + set result $next + } + TOSTATE { + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + set result [dict get $transition_to TOSTATE] + } + default { + #simplified version of TOSTATE + set result [lindex $transition_to 0] ;#ignore everything but first word + } + } + } else { + ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" + set result "nostate" + } + lappend state_list [list tokentype $tokentype from $currentstate to $result] + set state $result + ::tomlish::log::notice "--->> STATE TRANSITION tokenType: '$tokentype' tok:$tok triggering '$currentstate' -> '$result' last_space_action:$last_space_action " + return [dict create prevstate $prevstate newstate $result space_action $last_space_action starttok $starttok] + } + + proc report_line {{line ""}} { + variable linenum + variable is_parsing + if {$is_parsing} { + if {$line eq ""} { + set line $linenum + } + return "Line Number: $line" + } else { + #not in the middle of parsing tomlish text - return nothing. + return "" + } + } + + #produce a *slightly* more readable string rep of the nest for puts etc. + proc nest_pretty1 {list} { + set prettier "{" + + foreach el $list { + if { [lindex $el 0] eq "NEWLINE"} { + append prettier "[list $el]\n" + } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY DQKEY SQKEY TABLE ARRAY})} { + append prettier [nest_pretty1 $el] + } else { + append prettier "[list $el] " + } + } + append prettier "}" + return $prettier + } + + proc set_tokenType {t} { + variable tokenType + variable tokenType_list + if {![info exists tokenType]} { + set tokenType "" + } + lappend tokenType_list $t + set tokenType $t + } + + proc switch_tokenType {t} { + variable tokenType + variable tokenType_list + lset tokenType_list end $t + set tokenType $t + } + + proc get_tokenType {} { + variable tokenType + return $tokenType + } + + + proc get_token_waiting {} { + variable token_waiting + return [lindex $token_waiting 0] + } + proc clear_token_waiting {} { + variable token_waiting + set token_waiting [list] + } + + #token_waiting is a list - but our standard case is to have only one + #in certain circumstances such as near eof we may have 2 + #the set_token_waiting function only allows setting when there is not already one waiting. + #we want to catch cases of inadvertently trying to set multiple + # - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. + proc set_token_waiting {args} { + if {[llength $args] %2 != 0} { + error "tomlish set_token_waiting must have args of form: type value complete 0|1" + } + variable token_waiting + + if {[llength $token_waiting] && [dict get [lindex $token_waiting end] type] ne "eof"} { + #tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another + #we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context + #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it + set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" + append err \n " - cannot add token_waiting: $args" + error $err + #set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] + #set token_waiting [list] + } + + set waiting [dict create] + dict for {k v} $args { + switch -exact -- $k { + type - complete { + dict set waiting $k $v + } + value { + dict set waiting tok $v + } + startindex { + dict set waiting startindex $v + } + default { + error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" + } + } + } + if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { + error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" + } + if {![llength $token_waiting]} { + set token_waiting [list $waiting] + } else { + #an extra sanity-check that we don't have more than just the eof.. + if {[llength $token_waiting] > 1} { + set err "tomlish Unexpected. Existing token_waiting count > 1.\n" + foreach tw $token_waiting { + append err " $tw" \n + } + append err " - cannot add token_waiting: $waiting" + error $err + } + #last entry must be a waiting eof + set token_waiting [list $waiting [lindex $token_waiting end]] + } + return + } + + #returns 0 or 1 + #tomlish::parse::tok + #we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag + # - the possible benefit is being able to more easily process in arbitrarily split chunks (although we would still have to watch crlf splitting ?) + # - interactive use? + + proc tok {} { + variable nest + variable s + variable v + variable i + variable tok + variable type ;#character type + variable state ;#FSM + + + variable tokenType + variable tokenType_list + + + variable endToken + + variable lastChar + + variable braceCount + variable bracketCount + + + #------------------------------ + #Previous run found another (presumably single-char) token + #The normal case is for there to be only one dict in the list + #multiple is an exception - primarily for eof + variable token_waiting + if {[llength $token_waiting]} { + set waiting [lindex $token_waiting 0] + + set tokenType [dict get $waiting type] + set tok [dict get $waiting tok] + #todo: dict get $token_waiting complete + set token_waiting [lrange $token_waiting 1 end] + return 1 + } + #------------------------------ + + set resultlist [list] + set sLen [tcl::string::length $s] + + set slash_active 0 + set quote 0 + set c "" + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $s [expr {$i - 1}]] + set start_of_data h + } else { + set lastChar "" + set start_of_data 1 + #bom-handling + if {[tcl::string::index $s 0] eq "\uFEFF"} { + #bom (could be from various encodings - now decoded as single unicode char FEFF) + #incr i 1 ;#skip over initial bom? + } + } + + + set c [tcl::string::index $s $i] + set cindex $i + + set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] + tomlish::log::debug "- tokloop char <$ctest> index $i tokenType:$tokenType tok:<$tok>" + #puts "got char $c during tokenType '$tokenType'" + incr i ;#must incr here because we do returns inside the loop + + + + switch -exact -- $ctest { + # { + set had_slash $slash_active + set slash_active 0 + + if {$had_slash} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + #for multiliteral, multistring - data and/or end + incr i -1 + return 1 + } + _start_squote_sequence { + #pseudo token beginning with underscore - never returned to state machine - review + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" + } + whitespace { + # hash marks end of whitespace token + #do a return for the whitespace, set token_waiting + #set_token_waiting type comment value "" complete 1 + incr i -1 ;#leave comment for next run + return 1 + } + untyped_value { + #REVIEW! the spec isn't clear.. is whitespace after an int,bool etc required before comment? + #we will accept a comment marker as an immediate terminator of the untyped_value. + incr i -1 + return 1 + } + starttablename - starttablearrayname { + #fix? + error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out + append tok $c + } + default { + #dquotedkey, string,literal, multistring + append tok $c + } + } + } else { + switch -- $state { + multistring-space { + set_tokenType stringpart + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "#" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "#" + } + default { + #start of token if we're not in a token + set_tokenType comment + set tok "" ;#The hash is not part of the comment data + } + } + } + } + lc { + #left curly brace + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i [tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + #*bare* tablename can only contain letters,digits underscores + error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #valid in quoted parts + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\{" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + switch -exact -- $state { + itable-keyval-value-expected - keyval-value-expected { + #switch last key to tablename?? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + array-space - array-syntax { + #nested anonymous inline table + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\{" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\{" + } + default { + error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" + } + } + } + + } + rc { + #right curly brace + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey - comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - tablename { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endinlinetable value "" complete 1 startindex $cindex + return 1 + } + starttablearrayname - tablearrayname { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + #end any other token + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-space { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname-state problem" + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + #invalid + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-val-tail { + set_tokenType "endinlinetable" + set tok "" + #we need to pop the keyval - and then reprocess to pop the inlinetable - so we incr -1 + incr i -1 + return 1 + } + itable-keyval-syntax { + error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\}" + } + multiliteral-space { + set_tokenType "literalpart" ; #review + set tok "\}" + } + default { + #JMN2024b keyval-tail? + error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" + } + } + } + + } + lb { + #left square bracket + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename { + #change the tokenType + switch_tokenType "starttablearrayname" + set tok "" ;#no output into the tomlish list for this token + #any following whitespace is part of the tablearrayname, so return now + return 1 + } + tablename - tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + #append tok "\\[" + append tok {\[} + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + #invalid at this point - state machine should disallow: + # table -> starttablearrayname + # tablearray -> starttablearrayname + set_token_waiting type starttablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "\[" + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + keyval-value-expected - itable-keyval-value-expected { + set_tokenType "startarray" + set tok "\[" + return 1 + } + array-space - array-syntax { + #nested array? + set_tokenType "startarray" + set tok "\[" + return 1 + #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" + } + table-space { + #table name + #assume it's a single bracket - but we need to wait for non-bracket to confirm it's not a tablearray + #note that a starttablearrayname token may contain whitespace between the brackets + # e.g \[ \[ + set_tokenType "starttablename" + set tok "" ;#there is no output into the tomlish list for this token + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\[" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\[" + } + itable-space { + #handle state just to give specific error msg + error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[\] syntax. [tomlish::parse::report_line]" + } + default { + error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + rb { + #right square bracket + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + #???? + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } else { + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } + } + starttablename { + #toml-test invalid/table/empty + + set_token_waiting type tablename value "" complete 1 startindex $cindex + incr i -1 + return 1 + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablename value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + default { + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + array-syntax - array-space { + #invalid - but allow parser statemachine to report it. + set_tokenType "endarray" + set tok "\]" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endarray" + set tok "\]" + return 1 + } + tablename-state { + #e.g [] - empty tablename + #tomltest 1.1.0 invalid/table/empty + #should be invalid + #we parse it and let dict::from_tomlish error when it tries to split table + + set_tokenType "endtablename" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname problem" + set_tokenType "endtablearray" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-tail { + #[[xxx] + set_tokenType "endtablename" + #sequence: starttablename -> starttablearrayname -> endtablearrayname -> endtablename + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\]" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\]" + } + default { + error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + bsl { + #backslash + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + #end whitespace token + incr i -1 ;#reprocess bsl in next run + return 1 + } else { + error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" + } + } + literal - literalpart - squotedkey { + #never need to set slash_active true when in single quoted tokens + append tok "\\" + set slash_active 0 + } + string - dquotedkey - comment { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + stringpart { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + starttablename - starttablearrayname { + error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" + } + tablename - tablearrayname { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + barekey { + error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" + } + default { + error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$slash_active} { + set_tokenType "stringpart" + set tok "\\\\" + set slash_active 0 + } else { + set slash_active 1 + } + } + multiliteral-space { + #nothing can be escaped in multiliteral-space - not even squotes (?) review + set_tokenType "literalpart" + set tok "\\" + } + default { + error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" + } + } + } + } + sq { + #single quote + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote { + #for within multiliteral + #short tentative_accum_squote tokens are returned if active upon receipt of any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + #assert state = trailing-squote-space + append tok $c + if {$existingtoklen == 4} { + #maxlen to be a tentative_accum_squote is multisquote + 2 = 5 + #return tok with value ''''' + return 1 + } + } + tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + #pseudo/temp token creatable during keyval-value-expected itable-keyval-value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + #no conclusion can yet be reached + append tok $c + } + 2 { + #enter multiliteral + #switch? + append tok $c + set_tokenType triple_squote + return 1 + } + default { + #if there are more than 3 leading squotes we also enter multiliteral space and the subsequent ones are handled + #by the tentative_accum_squote check for ending sequence which can accept up to 5 and reintegrate the + #extra 1 or 2 squotes as data. + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" + } + } + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + #end whitespace + incr i -1 ;#reprocess sq + return 1 + } + literal { + #slash_active always false + #terminate the literal + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + literalpart { + #ended by ''' - but final could be '''' or ''''' (up to 2 squotes allowed directly before ending triple squote sequence) + #todo + # idea: end this literalpart (possibly 'temporarily') + # let the sq be reprocessed in the multiliteral-space to push an end-multiliteral-sequence to state stack + # upon popping end-multiliteral-sequence - stitch quotes back into this literalpart's token (if either too short - or a long ending sequence as shown above) + incr i -1 ;#throw the "'" back to loop - will be added to a tentative_accum_squote token for later processing + return 1 + } + XXXitablesquotedkey { + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + squotedkey { + ### + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + starttablename - starttablearrayname { + #!!! + incr i -1 + return 1 + } + tablename - tablearrayname { + append tok $c + } + barekey { + #barekeys now support all sorts of unicode letter/number chars for other cultures + #but not punctuation - not even for those of Irish heritage who don't object + #to the anglicised form of some names. + # o'shenanigan seems to not be a legal barekey + #The Irish will have to use an earlier form Ó - which apparently many may prefer anyway. + error "tomlish Unexpected single quote during barekey. [tomlish::parse::report_line]" + } + default { + append tok $c + } + } + } else { + switch -exact -- $state { + array-space - keyval-value-expected - itable-keyval-value-expected { + #leading squote + #pseudo-token _start_squote_sequence ss not received by state machine + #This pseudotoken will trigger production of single_squote token or triple_squote token + #It currently doesn't trigger double_squote token + #(handle '' same as 'x' ie produce a single_squote and go into processing literal) + #review - producing double_squote for empty literal may be slightly more efficient. + #This token is not used to handle squote sequences *within* a multiliteral + set_tokenType "_start_squote_sequence" + set tok "'" + } + multiliteral-space { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up a tentative_accum_squote to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "tentative_trigger_squote" ;#trigger tentative_accum_squote + set tok "'" + return 1 + } + table-space - itable-space { + #tests: squotedkey.test squotedkey_itable.test + set_tokenType "squotedkey" + set tok "" + } + XXXtable-space - XXXitable-space { + #future - could there be multiline keys? MLLKEY, MLBKEY ? + #this would (almost) allow arbitrary tcl dicts to be stored in toml (aside from escaping issues) + #probably unlikely - as it's perhaps not very 'minimal' or ergonomic for config files + #@2025 ABNF for toml mentions key, simple-key, unquoted-key, quoted-key and dotted-key + #where key is simple-key or dotted-key - no MLL or MLB components + #the spec states solution for arbitrary binary data is application specific involving encodings + #such as hex, base64 + set_tokenType "_start_squote_sequence" + set tok "'" + return 1 + } + tablename-state { + #first char in tablename-state/tablearrayname-state + set_tokenType "tablename" + append tok "'" + } + tablearrayname-state { + set_tokenType "tablearrayname" + append tok "'" + } + literal-state { + #shouldn't get here? review + tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?" + set_tokenType "literal" + incr -1 + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "," + #error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" + } + dottedkey-space { + set_tokenType "squotedkey" + } + default { + error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" + } + } + } + + } + dq { + #double quote + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #review + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + tentative_accum_dquote { + #within multistring + #short tentative_accum_dquote tokens are returned if active upon receipt of any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + #assert state = trailing-squote-space + append tok $c + if {$existingtoklen == 4} { + #maxlen to be a tentative_accum_dquote is multidquote + 2 = 5 + #return tok with value """"" + return 1 + } + } + _start_dquote_sequence { + #pseudo/temp token creatable during keyval-value-expected itable-keyval-value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + #no conclusion can yet be reached + append tok $c + } + 2 { + #enter multistring + #switch? + append tok $c + set_tokenType triple_dquote + return 1 + } + default { + #if there are more than 3 leading dquotes we also enter multistring space and the subsequent ones are handled + #by the tentative_accum_dquote check for ending sequence which can accept up to 5 and reintegrate the + #extra 1 or 2 dquotes as data. + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_dquote_sequence'" + } + } + } + literal - literalpart { + append tok $c + } + string { + if {$had_slash} { + append tok "\\" $c + } else { + #unescaped quote always terminates a string + set_token_waiting type enddquote value "\"" complete 1 startindex $cindex + return 1 + } + } + stringpart { + #sub element of multistring + if {$had_slash} { + append tok "\\" $c + } else { + incr i -1 ;#throw the {"} back to loop - will be added to a tentative_accum_dquote token for later processing + return 1 + } + } + whitespace { + #assert: had_slash will only ever be true in multistring-space + if {$had_slash} { + incr i -2 + return 1 + } else { + #end whitespace token - throw dq back for reprocessing + incr i -1 + return 1 + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + XXXdquotedkey { + if {$had_slash} { + append tok "\\" + append tok $c + } else { + set_token_waiting type enddquote value "\"" complete 1 startindex $cindex + return 1 + } + } + dquotedkey { + ### + if {$had_slash} { + append tok "\\" + append tok $c + } else { + #set_token_waiting type enddquote value {"} complete 1 + return 1 + } + } + squotedkey { + append tok $c + } + tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + incr i -1 ;## + return 1 + } + default { + error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + #$slash_active not relevant when no tokenType + #token is string only if we're expecting a value at this point + switch -exact -- $state { + array-space - keyval-value-expected - itable-keyval-value-expected { + #leading dquote + #pseudo-token _start_squote_sequence ss not received by state machine + #This pseudotoken will trigger production of single_dquote token or triple_dquote token + #It currently doesn't trigger double_dquote token + #(handle "" same as "x" ie produce a single_dquote and go into processing string) + #review - producing double_dquote for empty string may be slightly more efficient. + #This token is not used to handle dquote sequences once *within* a multistring + set_tokenType "_start_dquote_sequence" + set tok {"} + } + multistring-space { + if {$had_slash} { + set_tokenType "stringpart" + set tok "\\\"" + } else { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up a tentative_accum_squote to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "tentative_trigger_dquote" ;#trigger tentative_accum_dquote + set tok {"} + return 1 + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\"" + } + table-space - itable-space { + set_tokenType "dquotedkey" + set tok "" + } + dottedkey-space { + set_tokenType dquotedkey + set tok "" + + #only if complex keys become a thing + #set_tokenType dquote_seq_begin + #set tok $c + } + tablename-state { + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + default { + error "tomlish Unexpected dquote during state '$state' [tomlish::parse::report_line]" + } + } + } + } + = { + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #review + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + #assertion had_slash 0 + append tok $c + } + string - comment - dquotedkey { + #for these tokenTypes an = is just data. + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + set_token_waiting type equal value = complete 1 startindex $cindex + return 1 + } + } + barekey { + #set_token_waiting type equal value = complete 1 + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out + append tok $c + } + default { + error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok = + } + multiliteral-space { + set_tokenType "literalpart" + set tok "=" + } + dottedkey-space { + set_tokenType "equal" + set tok "=" + return 1 + } + default { + set_tokenType "equal" + set tok = + return 1 + } + } + } + } + cr { + #REVIEW! + # \r carriage return + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #we have received a double cr + ::tomlish::log::warn "double cr - will generate cr token. needs testing" + set_tokenType "cr" ;#lone cr token will generally raise an error - but let state machine handle it + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal { + append tok $c + } + literalpart { + #part of MLL string (multi-line literal string) + #we need to split out crlf as a separate NEWLINE to be consistent + ::tomlish::log::warn "literalpart ended by cr - needs testing" + #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space + incr i -1 + return 1 + } + stringpart { + #stringpart is a part of MLB string (multi-line basic string) + #throw back the cr - if followed by lf it will become a {NEWLINE crlf} entry within the MULTISTRING list (e.g between STRINGPART entries) + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #could in theory be valid in quoted part of name + #review - might be better just to disallow here + append tok $c + } + whitespace { + #it should technically be part of whitespace if not followed by lf + #but outside of values we are also free to map it to be another NEWLINE instead? REVIEW + incr i -1 + return 1 + } + untyped_value { + incr i -1 + return 1 + } + comment { + #JJJJ + #review + incr i -1 + return 1 + } + default { + #!todo - error out if cr inappropriate for tokenType + append tok $c + } + } + } else { + #lf may be appended if next + #review - lone cr as newline? - this is uncommon - but so is lone cr in a string(?) + set_tokenType "newline" + set tok cr + } + } + lf { + # \n newline + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #review + #this lf is the trailing part of a crlf + append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + #multiliteral or multistring + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal { + #nl is not allowed *within* a literal - require multiliteral syntax for any literal containing a newline ''' ''' + #even though we terminate the literal without the closing quote here - the token_waiting newline should trigger a state error + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + literalpart { + #we allow newlines - but store them within the multiliteral as their own element + #This is a legitimate end to the literalpart - but not the whole multiliteral + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + stringpart { + if {$had_slash} { + #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) + set_token_waiting type continuation value \\ complete 1 startindex [expr {$cindex-1}] + incr i -1 + return 1 + } else { + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + starttablename - tablename - tablearrayname - starttablearrayname { + error "tomlish Character is invalid in $tokenType. [tomlish::parse::report_line]" + } + default { + #newline ends all other tokens. + #note for string: we don't add (raw unescaped) newline to simple string. (must use multi-string for this) + #note for whitespace: + # we will use the convention that \n terminates the current whitespace even if whitespace follows + # ie whitespace is split into separate whitespace tokens at each newline + + #puts "-------------- newline lf during tokenType $tokenType" + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType "newline" + set tok lf + return 1 + } + } + multiliteral-space { + #assert had_slash 0 + set_tokenType "newline" + set tok "lf" + return 1 + } + default { + #ignore slash? error? + set_tokenType "newline" + set tok lf + return 1 + } + } + #if {$had_slash} { + # #CONT directly before newline - allows strings_5_byteequivalent test to pass + # set_tokenType "continuation" + # set tok "\\" + # incr i -1 + # return 1 + #} else { + # set_tokenType newline + # set tok lf + # return 1 + #} + } + } + , { + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + comment - tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok , + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + #stringpart can have up to 2 quotes too + if {$had_slash} {append tok "\\"} + append tok $c + } + literal - literalpart - squotedkey { + #assert had_slash always 0 + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + set_token_waiting type comma value "," complete 1 startindex $cindex + return 1 + } + } + default { + set_token_waiting type comma value "," complete 1 startindex $cindex + if {$had_slash} {append tok "\\"} + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "," + } + multiliteral-space { + #assert had_slash 0 + set_tokenType "literalpart" + set tok "," + } + default { + set_tokenType "comma" + set tok "," + return 1 + } + } + } + } + . { + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + comment - untyped_value { + if {$had_slash} {append tok "\\"} + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + literal - literalpart - squotedkey { + #assert had_slash always 0 + append tok $c + } + whitespace { + switch -exact -- $state { + multistring-space { + #review + if {$had_slash} { + incr i -2 + } else { + incr i -1 + } + return 1 + } + xxxdottedkey-space { + incr i -1 + return 1 + } + dottedkey-space-tail { + incr i -1 + return 1 + } + default { + error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" + } + } + } + starttablename - starttablearrayname { + #This would correspond to an empty table name + error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #subtable - split later - review + append tok $c + } + barekey { + #e.g x.y = 1 + #we need to transition the barekey to become a structured table name ??? review + #x is the tablename y is the key + set_token_waiting type dotsep value "." complete 1 startindex $cindex + return 1 + } + default { + error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" + #set_token_waiting type period value . complete 1 + #return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "." + } + multiliteral-space { + set_tokenType "literalpart" + set tok "." + } + XXXdottedkey-space { + ### obs? + set_tokenType "dotsep" + set tok "." + return 1 + } + dottedkey-space-tail { + ### + set_tokenType "dotsep" + set tok "." + return 1 + } + default { + set_tokenType "untyped_value" + set tok "." + } + } + } + + } + " " - tab { + if {[tcl::string::length $tokenType]} { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + #todo had_slash - emit token or error + #whitespace is a terminator for bare keys + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + comment { + if {$had_slash} { + append tok "\\" + } + append tok $c + } + string - dquotedkey { + if {$had_slash} { append tok "\\" } + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART xxx WS " " + incr i -1 + return 1 + } + } + literal - literalpart - squotedkey { + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + append tok $c + } else { + append tok $c + } + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType "whitespace" + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + if {$had_slash} { + error "tomlish unexpected backslash [tomlish::parse::report_line]" + } + set_tokenType "whitespace" + append tok $c + } + } + } + } + tabX { + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out (?review) + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + #whitespace is a terminator for bare keys + incr i -1 + #set_token_waiting type whitespace value $c complete 1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + squotedkey { + append tok $c + } + dquotedkey - string - comment - whitespace { + #REVIEW + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + incr i -1 + return 1 + } + } + literal - literalpart { + append tok $c + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + if {$slash_active} { + set slash_active 0 + } + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType whitespace + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "whitespace" + append tok $c + } + } + } + } + bom { + #bom encoded as single unicode codepoint \uFFEF + #BOM (Byte Order Mark) - ignored by token consumer + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + #assert - tok will be one or two squotes only + #A toml literal probably isn't allowed to contain this + #but we will parse and let the validator sort it out. + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart { + append tok $c + } + string - stringpart { + append tok $c + } + default { + #state machine will generally not have entry to accept bom - let it crash + set_token_waiting type bom value "\uFEFF" complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + multistring-space { + set_tokenType "stringpart" + set tok $c + } + default { + set_tokenType "bom" + set tok "\uFEFF" + return 1 + } + } + } + } + default { + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + #review + incr i -1 ;#We don't have a full token to add to the token_waiting dict - so leave this char for next run. + return 1 + } + } + barekey { + if {[tomlish::utils::is_barekey $c]} { + append tok $c + } else { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" + } + } + starttablename - starttablearrayname { + incr i -1 + #allow statemachine to set context for subsequent chars + return 1 + } + string - stringpart { + append tok $c + } + default { + #e.g comment/literal/literalpart/untyped_value/starttablename/starttablearrayname/tablename/tablearrayname + append tok $c + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + table-space - itable-space { + #if no currently active token - assume another key value pair + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + multistring-space { + set_tokenType "stringpart" + if {$had_slash} { + set tok \\$c + } else { + set tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + tablename-state { + set_tokenType "tablename" + set tok $c + } + tablearrayname-state { + set_tokenType "tablearrayname" + set tok $c + } + dottedkey-space { + set_tokenType barekey + set tok $c + } + default { + #todo - something like ansistring VIEW to show control chars? + set cshow [string map [list \t tab \v vt] $c] + tomlish::log::debug "- tokloop char '$cshow' setting to untyped_value while state:$state [tomlish::parse::report_line]" + set_tokenType "untyped_value" + set tok $c + } + } + } + } + } + + } + + #run out of characters (eof) + if {[tcl::string::length $tokenType]} { + #check for invalid ending tokens + #if {$state eq "err-state"} { + # error "Reached end of data whilst tokenType = '$tokenType'. INVALID" + #} + switch -exact -- $tokenType { + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open literal + error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" + } + 2 { + set_tokenType "literal" + set tok "" + return 1 + + ##review + #set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] + #set_tokenType "literal" + #set tok "" + #return 1 + } + } + } + _start_dquote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open string + error "tomlish eof reached without closing double quote for string. [tomlish::parse::report_line]" + } + 2 { + set_tokenType "string" + set tok "" + return 1 + } + } + } + newline { + #The only newline token that has still not been returned should have a tok value of "cr" + puts "tomlish eof reached - with incomplete newline token '$tok'" + if {$tok eq "cr"} { + #we convert lone cr to it's own "cr" token elsewhere in the document to allow statemachine to handle it. + #(which it should generally do by not handling it ie raising an error - or emitting an ERROR list in the tomlish) + #if trailing char is a lone cr - we should encode it the same way as elsewhere that is outside of values + # ie as it's own token. + switch_tokenType "cr" + return 1 + } else { + #should be unreachable + error "tomlish eof reached - with invalid newline token. value: $tok" + } + } + } + set_token_waiting type eof value eof complete 1 startindex $i ;#review + return 1 + } else { + ::tomlish::log::debug "- No current tokenType, ran out of characters, setting tokenType to 'eof' [tomlish::parse::report_line]" + set tokenType "eof" + set tok "eof" + } + return 0 + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::parse ---}] +} +namespace eval tomlish::huddle { + proc from_json {json} { + package require huddle + package require huddle::json + #note - huddle may now contain raw surrogate pair - which cannot be emitted to stdout + 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 + proc jsondumpraw {huddle_object {offset " "} {newline "\n"} {begin ""}} { + upvar ::huddle::types types + set nextoff "$begin$offset" + set nlof "$newline$nextoff" + set sp " " + if {[string equal $offset ""]} {set sp ""} + + set type [huddle type $huddle_object] + + switch -- $type { + boolean - + number { + return [huddle get_stripped $huddle_object] + } + null { + return null + } + string { + set data [huddle get_stripped $huddle_object] + + # JSON permits only oneline string + #set data [string map { + # \n \\n + # \t \\t + # \r \\r + # \b \\b + # \f \\f + # \\ \\\\ + # \" \\\" + # / \\/ + # } $data + #] + return "\"$data\"" + } + list { + set inner {} + set len [huddle llength $huddle_object] + for {set i 0} {$i < $len} {incr i} { + set subobject [huddle get $huddle_object $i] + lappend inner [jsondumpraw $subobject $offset $newline $nextoff] + } + if {[llength $inner] == 1} { + return "\[[lindex $inner 0]\]" + } + return "\[$nlof[join $inner ,$nlof]$newline$begin\]" + } + dict { + set inner {} + foreach {key} [huddle keys $huddle_object] { + lappend inner [subst {"$key":$sp[jsondumpraw [huddle get $huddle_object $key] $offset $newline $nextoff]}] + } + #if {[llength $inner] == 1} { + # return $inner ;#wrong - breaks with quoted list representation + # #FAILS: toml-test valid/comment/tricky + #} + + return "\{$nlof[join $inner ,$nlof]$newline$begin\}" + } + default { + set node [unwrap $huddle_object] + #foreach {tag src} $node break + lassign $node tag src + return [$types(callback:$tag) jsondumpraw $huddle_object $offset $newline $nextoff] + } + } + } +} + +#typed as per toml-test types +namespace eval tomlish::typedhuddle { + proc from_json {json} { + set plainhuddle [tomlish::huddle::from_json $json] + + error "tomlish::typedhuddle::from_json unimplemented" + } + proc from_dict {d} { + package require huddle + set h [huddle create] + if {[tomlish::dict::is_typeval $d]} { + set dtype [dict get $d type] + switch -- $dtype { + ARRAY { + #error "typedhuddle::from_dict ARRAY not yet handled" + set h_list [huddle list] + set elements [dict get $d value] + foreach el $elements { + set sub [from_dict $el] + huddle append h_list $sub + } + return $h_list + } + default { + set tinfo [tomlish::dict::convert_typeval_to_tomltest $d] + #basic non-container types + set h_tdict [huddle create] + huddle set h_tdict type [huddle string [dict get $tinfo type]] + huddle set h_tdict value [huddle string [dict get $tinfo value]] + return $h_tdict + } + } + } else { + dict for {dictkey dictval} $d { + set jsonkey [tomlish::utils::rawstring_to_jsonstring $dictkey] + if {[tomlish::dict::is_typeval $dictval]} { + set dtype [dict get $dictval type] + switch -- $dtype { + ARRAY { + #error "typedhuddle::from_dict ARRAY not yet handled" + set h_next [huddle list] + set elements [dict get $dictval value] + foreach el $elements { + set sub [from_dict $el] + huddle append h_next $sub + } + } + default { + set tinfo [tomlish::dict::convert_typeval_to_tomltest $dictval] + set tp [dict get $tinfo type] + #basic non-container types + set h_next [huddle create] ;#dict + huddle set h_next type [huddle string [dict get $tinfo type]] + huddle set h_next value [huddle string [dict get $tinfo value]] + } + } + huddle set h $jsonkey $h_next + } else { + #dict + set sub [from_dict $dictval] + huddle set h $jsonkey $sub + } + } + } + return $h + } + proc is_typeval {huddled} { + set htype [huddle type $huddled] + if {$htype ne "dict"} { + return 0 + } + if {[huddle keys $huddled] ne {type value}} { + return 0 + } + set tp [huddle type $huddled type] + switch -- $tp { + string - integer - float - bool - datetime - datetime-local - date-local - time-local { + return 1 + } + } + return 0 + } + + #direction from typed json towards toml + proc convert_typeval_to_tomlish {huddled} { + set htype [huddle get_stripped $huddled type] + set hval [huddle get_stripped $huddled value] + switch -- $htype { + string { + #we need to decide here the type of string element to use in toml/tomlish + #STRING,MULTISTRING,LITERAL,MULTILITERAL + #set unesc [tomlish::utils::unescape_jsonstring $hval] ;#no need - json parser unescaped when creating the huddle + set unesc $hval + #(huddle::json::json2huddle parse $json) + #since it was unescaped any backslashes remaining represent themselves - reapply escape - REVIEW + #set hval [string map [list \\ \\\ ] $hval] + #JSJS + if {[string first \n $unesc] >= 0} { + #always use a MULTI + if {[string first ' $unesc] >=0} { + if {[string first ''' $unesc] >=0} { + set dtype MULTISTRING + } else { + set dtype MULTILITERAL + } + } else { + if {[string first \"\"\" $unesc] >=0} { + set dtype MULTILITERAL + } else { + set dtype MULTISTRING + } + } + } else { + #use multi if needed? + if {[string first '' $hval] >=0} { + if {[string first ''' $unesc] >=0} { + set dtype STRING + } else { + set dtype MULTILITERAL + } + } elseif {[string first ' $unesc] >= 0} { + set dtype STRING + } elseif {[string first \"\"\" $unesc] >= 0} { + set dtype LITERAL + } else { + #STRING or LITERAL? + set dtype STRING + } + } + + } + datetime - bool { + set dtype [string toupper $htype] + } + float { + set dtype FLOAT + if {[::tomlish::utils::string_is_integer -strict $hval]} { + #json FLOAT specified as integer - must have dot for toml + set hval [expr {double($hval)}] + } + } + integer { + set dtype INT + } + datetime - datetime-local - date-local - time-local { + #DDDD + #set dtype DATETIME + set dtype [string toupper $htype] + } + default { + error "tomlish::typedhuddle::convert_typeval_to_tomlish unrecognised type $htype" + } + } + return [list type $dtype value $hval] + } + +} +namespace eval tomlish::toml { + proc from_binary {bindata} { + set bom "" + set b12 [tcl::string::range $bindata 0 1] + set b12test [string map [list \xEF\xBB utf8_12 \xFE\xFF bom16be \xFF\xFE utf32le_12 \x00\x00 utf32be_12] $b12] + switch -- $b12test { + bom16be { + #FEFF + set bom utf-16be + } + utf32le_12 { + #FFFE + set b34 [tcl::string::range $bindata 2 3] + if {$b34 eq "\x00\x00"} { + set bom utf-32le + } else { + set bom utf-16le + } + } + utf32be_12 { + #0000 + set b34 [tcl::string::range $bindata 2 3] + if {$b34 eq "\xFE\xFF"} { + set bom utf-32be + } + } + utf8_12 { + set b3 [tcl::string::index $bindata 2] + if {$b3 eq "\xBF"} { + set bom utf-8 + } + } + } + if {$bom eq ""} { + #no bom - assume utf8 - but we read in as binary + #if data wasn't actually utf8 we may error here depending on content - or we may just get wrongly encoded chars + set tomldata [encoding convertfrom utf-8 $bindata] + } elseif {$bom eq "utf-8"} { + #utf-8 bom read in as binary + set tomldata [encoding convertfrom utf-8 $bindata] + #bom now encoded as single unicode char \uFFEF + } else { + return -code error -errorcode {TOML ENCODING NOTUTF8} "Input not UTF8 encoded according to BOM. Indicated encoding is '$bom' - invalid for toml" + } + return $tomldata + } + proc from_tomlish {tomlish} { + return [tomlish::encode::tomlish $tomlish] + } + + #todo - rename to taggedjson + proc from_tomlish_from_dict_from_typedjson {json} { + set d [tomlish::dict::from_typedjson $json] + from_tomlish [tomlish::from_dict $d] ;#return tomlish + } + + proc tablename_split {tablename {normalize false}} { + #we can't just split on . because we have to handle quoted segments which may contain a dot. + #eg {dog."tater.man"} + if {$tablename eq ""} { + error "tablename_split. No table name segments found. empty tablename" + } + set sLen [tcl::string::length $tablename] + set segments [list] + set mode "preval" ;#5 modes: preval, quoted,litquoted, unquoted, postval + #quoted is for double-quotes, litquoted is for single-quotes (string literal) + set seg "" + for {set i 0} {$i < $sLen} {incr i} { + + if {$i > 0} { + set lastChar [tcl::string::index $tablename [expr {$i - 1}]] + } else { + set lastChar "" + } + + #todo - track\count backslashes properly + + set c [tcl::string::index $tablename $i] + if {$c eq "\""} { + if {($lastChar eq "\\")} { + #not strictly correct - we could have had an even number prior-backslash sequence + #the toml spec would have us error out immediately on bsl in bad location - but we're + #trying to parse to unvalidated tomlish + set ctest escq + } else { + set ctest dq + } + } else { + set ctest [string map [list " " sp \t tab] $c] + } + + switch -- $ctest { + . { + switch -exact -- $mode { + preval { + error "tablename_split. dot not allowed - expecting a value" + } + unquoted { + #dot marks end of segment. + if {![tomlish::utils::is_barekey $seg]} { + error "tablename_split. unquoted key segment $seg is not a valid toml key" + } + lappend segments $seg + set seg "" + set mode "preval" + } + quoted { + append seg $c + } + litquoted { + append seg $c + } + postval { + #got dot in an expected location + set mode "preval" + } + } + } + dq { + #unescaped dquote + switch -- $mode { + preval { + set mode "quoted" + set seg "\"" + } + unquoted { + #invalid in barekey - but we are after structure only + append seg $c + } + quoted { + append seg $c + #JJJJ + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + } else { + lappend segments $seg + } + set seg "" + set mode "postval" ;#make sure we only accept a dot or end-of-data now. + } + litquoted { + append seg $c + } + postval { + error "tablename_split. expected whitespace or dot, got double quote. tablename: '$tablename'" + } + } + } + ' { + switch -- $mode { + preval { + append seg $c + set mode "litquoted" + } + unquoted { + #single quote inside e.g o'neill - ultimately invalid - but we pass through here. + append seg $c + } + quoted { + append seg $c + } + litquoted { + append seg $c + #no normalization to do aside from stripping squotes + if {$normalize} { + lappend segments [tcl::string::range $seg 1 end-1] + } else { + lappend segments $seg + } + set seg "" + set mode "postval" + } + postval { + error "tablename_split. expected whitespace or dot, got single quote. tablename: '$tablename'" + } + } + } + sp - tab { + switch -- $mode { + preval - postval { + #ignore + } + unquoted { + #terminates a barekey + lappend segments $seg + set seg "" + set mode "postval" + } + default { + #append to quoted or litquoted + append seg $c + } + } + } + default { + switch -- $mode { + preval { + set mode unquoted + append seg $c + } + postval { + error "tablename_split. Expected a dot separator. got '$c'. tablename: '$tablename'" + } + default { + append seg $c + } + } + } + } + + if {$i == $sLen-1} { + #end of data + ::tomlish::log::debug "End of data: mode='$mode'" + switch -exact -- $mode { + preval { + if {[llength $segments]} { + error "tablename_split. Expected a value after last dot separator. tablename: '$tablename'" + } else { + error "tablename_split. Whitespace only? No table name segments found. tablename: '$tablename'" + } + } + unquoted { + if {![tomlish::utils::is_barekey $seg]} { + #e.g toml-test invalid/table/with-pound required to fail for invalid barekey + error "tablename_split. unquoted key segment $seg is not a valid toml key" + } + lappend segments $seg + } + quoted { + error "tablename_split. Expected a trailing double quote. tablename: '$tablename'" + } + litquoted { + error "tablename_split. Expected a trailing single quote. tablename: '$tablename'" + } + postval { + #ok - segment already lappended + } + } + } + } + + #note - we must allow 'empty' quoted strings '' & "" + # (these are 'discouraged' but valid toml keys) + + return $segments + } + + #tablenames (& tablearraynames) may contain irrelevant leading, trailing and interspersed whitespace + # tablenames can be made up of segments delimited by dots. .eg [ a.b . c ] + #trimmed, the tablename becomes {a.b.c} + # A segment may contain whitespace if it is quoted e.g [a . b . "c etc " ] + #ie whitespace is only irrelevant if it's outside a quoted segment + #trimmed, the tablename becomes {a.b."c etc "} + proc tablename_trim {tablename} { + set segments [tomlish::toml::tablename_split $tablename false] + set trimmed_segments [list] + foreach seg $segments { + lappend trimmed_segments [::string trim $seg " \t"] + } + return [join $trimmed_segments .] + } +} + +namespace eval tomlish::dict { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + + #from_taggedjson + proc from_typedjson {json} { + package require huddle + package require huddle::json + set h [huddle::json::json2huddle parse $json] + #json2huddle parse unescapes the basic json escapes \n \\ etc + #$h could now contain raw form of surrogate pair (json2huddle parse as at 2025-014 doesn't convert the surrogates - just unescapes?) + if {[catch {encoding convertto utf-8 $h} errM]} { + #This test suggests we have raw surrogate pairs - REVIEW + package require punk::cesu + set h [punk::cesu::from_surrogatestring $h] + } + tomlish::dict::from_typedhuddle $h + } + proc from_typedhuddle {h} { + set resultd [dict create] + switch -- [huddle type $h] { + dict { + foreach k [huddle keys $h] { + switch -- [huddle type $h $k] { + dict { + set huddle_d [huddle get $h $k] + #puts stderr "huddle_d: $huddle_d" + #set v [huddle get_stripped $h $k] + if {[tomlish::typedhuddle::is_typeval $huddle_d]} { + dict set resultd $k [tomlish::typedhuddle::convert_typeval_to_tomlish $huddle_d] + } else { + dict set resultd $k [from_typedhuddle $huddle_d] + } + } + list { + set items [huddle get $h $k] + + set numitems [huddle llength $items] + if {$numitems == 0} { + dict set resultd $k [list type ARRAY value {}] + } else { + set arritems [list] + for {set i 0} {$i < $numitems} {incr i} { + set item [huddle get $items $i] + #puts stderr "item: $item" + #set v [huddle get $item] + if {[tomlish::typedhuddle::is_typeval $item]} { + lappend arritems [tomlish::typedhuddle::convert_typeval_to_tomlish $item] + } else { + lappend arritems [from_typedhuddle $item] + } + } + dict set resultd $k [list type ARRAY value $arritems] + } + } + default { + error "dict_from_json unexpected subtype [huddle type $h $k] in dict" + } + } + } + } + list { + set items [huddle get $h] + set numitems [huddle llength $items] + if {$numitems == 0} { + return [list type ARRAY value {}] + } else { + set arritems [list] + for {set i 0} {$i < $numitems} {incr i} { + set item [huddle get $items $i] + #puts stderr "item: $item" + #set v [huddle get $item] + if {[tomlish::typedhuddle::is_typeval $item]} { + lappend arritems [tomlish::typedhuddle::convert_typeval_to_tomlish $item] + } else { + lappend arritems [from_typedhuddle $item] + } + } + return [list type ARRAY value $arritems] + } + + } + } + return $resultd + } + + proc is_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[::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? + proc convert_typeval_to_tomltest {d} { + set dtype [dict get $d type] + set dval [dict get $d value] + switch -- $dtype { + INT { + set testtype integer + set dval [expr {$dval}] ;#convert e.g 0xDEADBEEF to 3735928559 + } + 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 { + set testtype string + #JJJJ + set dval [tomlish::utils::unescape_string $dval] + set dval [tomlish::utils::rawstring_to_jsonstring $dval] + } + LITERAL - MULTILITERAL { + set testtype string + #don't validate on way out to json here? + #decoder should validate by calling tomlish::from_dict + #if {![tomlish::utils::rawstring_is_valid_literal $dval]} { + # return -code error -errorcode {TOML SYNTAX INVALIDLITERAL} $msg + #} + set dval [tomlish::utils::rawstring_to_jsonstring $dval] + } + default { + error "convert_typeval_to_tomltest unhandled type $dtype" + } + } + return [list type $testtype value $dval] + } + + # 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 {![::tomlish::utils::string_is_dict $d]} { + return 0 + } + dict for {k v} $d { + set is_d 0 + if {!([is_typeval $v] || [set is_d [is_typeval_dict $v $checkarrays]])} { + return 0 + } + if {!$is_d} { + set vtype [dict get $v type] + switch -- $vtype { + INT - FLOAT - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - BOOL - LITERAL - STRING - MULTILITERAL - MULTISTRING {} + ARRAY { + if {$checkarrays} { + set arrdata [dict get $v value] + foreach el $arrdata { + if {![is_typeval_dict $el $checkarrays]} { + return 0 + } + } + } + } + default { + puts stderr "is_typeval_dict: Unexpected type '$vtype'" + return 0 + } + } + } + } + return 1 + } + + proc last_tomltype_posn {d} { + set last_simple -1 + set dictposn [expr {[dict size $d] -1}] + foreach k [lreverse [dict keys $d]] { + set dval [dict get $d $k] + if {[is_typeval $dval]} { + set last_simple $dictposn + break + } + incr dictposn -1 + } + return $last_simple + } + + + #review + proc name_from_tablestack {tablestack} { + set name "" + foreach tinfo [lrange $tablestack 1 end] { + lassign $tinfo type namepart + switch -- $type { + T { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + I { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + default { + #end at first break in the leading sequence of T & I tablenames + break + } + } + } + return $name + } + + + #tablenames_info is a flat dict with the key being an '@@' path + proc _show_tablenames {tablenames_info} { + #e.g {@l@a @@b} {ttype header_table tdefined closed} + append msg \n "tablenames_info:" \n + dict for {tkey tinfo} $tablenames_info { + append msg " " "table: $tkey" \n + dict for {field finfo} $tinfo { + append msg " " "$field $finfo" \n + } + } + return $msg + } + + #take a raw string and classify: result is a 2 element list comprised of KEY|SQKEY|DQKEY and the value being the appropriate inner string + proc classify_rawkey {rawval} { + if {![::tomlish::utils::is_barekey $rawval]} { + #requires quoting + # + #Any dot in the key would have been split by dict::from_tomlish - so if it's present here it's part of this key - not a level separator! + # + #we'll use a basic mechanisms for now to determine the type of quoting + # - whether it has any single quotes or not. + # (can't go in an SQKEY) + # - whether it has any chars that require quoting when in a Bstring + # (if so - then its visual representation might be unsuitable for a key in a toml text file, so escape and put in DQKEY instead of literal SQKEY) + #todo - more? + #REVIEW - the backslash might often be in things like a regex or windows path - which is often better expressed in a literal SQKEY + # from literal examples: + # 'c:\Users\nodejs\templates' + # '<\i\c*\s*>' + #If these are in *keys* our basic test will express these as: + # "c:\\Users\\nodejs\\templates" + # "<\\i\\c*\\s*>" + # This still works - but a smarter test might determine when SQKEY is the better form? + #when coming from external systems - can we even know if the value was already escaped? REVIEW + #Probably when coming from json - we know it's already escaped - and so we build our dict converting keys to unescaped + #TODO - clarify in documentation that keys resulting from dict::from_tomlish are in 'normalized' (unescaped) form + # + #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) + set k_escaped [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $rawval] + if {[string length $k_escaped] != [string length $rawval]} { + #escaping made a difference + set has_escape_requirement 1 + } else { + set has_escape_requirement 0 + } + if {[string first ' $rawval] >=0 || $has_escape_requirement} { + #basic string + # (any ANSI SGR sequence will end up here in escaped form ) + return [list DQKEY $k_escaped] + } else { + #literal string + return [list SQKEY $rawval] + } + } else { + return [list KEY $rawval] + } + } + #the quoting implies the necessary escaping for DQKEYs + proc join_and_quote_rawkey_list {rawkeylist} { + set result "" + foreach rk $rawkeylist { + lassign [tomlish::dict::classify_rawkey $rk] type val + switch -- $type { + SQKEY { + append result "'$val'." + } + DQKEY { + append result "\"$val\"." + } + KEY { + append result "$val." + } + } + } + return [string range $result 0 end-1] + } + + proc _process_tomlish_dottedkey {element {context_refpath {}}} { + upvar tablenames_info tablenames_info + upvar datastructure datastructure + set dottedtables_defined [list] + set dkey_info [tomlish::get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.leafkey = "val" + #we have already checked supertables a & {a b} + # - in basic case, passed in context_refpath as {@@a @@b} + # - our context_refpath could also include some combination of keys and array indices e.g {@@a @@b 3 @@subtablekey} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while leafkey is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with the following even though there is no dot in k + #[a.b] + #leafkey = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #k = 1 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #see also: https://github.com/toml-lang/toml/issues/846 "Can dotted keys insert into already-defined [tables]?" + #This code was originally written with a misinterpretation of: + #"Dotted keys create and define a table for each key part before the last one, provided that such tables were not previously created." + # 'each key part before the last one' refers to each key in a single dotted key entry + # not each 2nd-to last key in a list of dotted keys. + + + #we've already tested the table/tablearray keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + set dottedsuper_refpath $context_refpath + foreach normkey $dotparents { + lappend dottedsuper_refpath @@$normkey + if {![dict exists $tablenames_info $dottedsuper_refpath ttype]} { + #supertable with this combined path (context_path plus parts of dottedkey) not yet 'created' + if {[tomlish::dict::path::exists $datastructure $dottedsuper_refpath]} { + #There is data so it must have been created as a keyval + set msg "Path $dottedsuper_refpath for dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + #dict set tablenames_info $dottedsuper_refpath ttype unknown_table ;#REVIEW + dict set tablenames_info $dottedsuper_refpath ttype unknown_dotted ;#REVIEW + + #see note above re dotted keys insert into already defined table - we need to 'define' all the dotted supers in this block + lappend dottedtables_defined $dottedsuper_refpath + + #ensure empty tables are still represented in the datastructure + 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] + set definedstate [dictn getdef $tablenames_info [list $dottedsuper_refpath tdefined] NULL] + switch -- $ttype { + dottedkey_table - unknown_dotted { + #'created' as dotted - but make sure it's from this header section - i.e defined not set + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table at $dottedsuper_refpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (table redefinition) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } + } + itable { + #itables are immediately defined + set msg "Table at $dottedsuper_refpath represented by dottedkey $dottedkeyname has been 'defined' as itable (table redefinition) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } + default { + #header_table, header_tablearray or unknown_header + #is header_tablearray any different from header_table in this context? + #we don't set tdefined for tablearray anyway - so should be ok here. + if {$definedstate ne "NULL"} { + set msg "Table at $dottedsuper_refpath represented by dottedkey $dottedkeyname has been 'defined' in a header (table redefinition) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } + } + } + } + } + + #dottedtable being 2nd last segment was for original assumption - todo - tidy up? we are duplicating the logic above + #review - any need/advantage to treat 2nd to last key any different from other supers? ie D in a.b.c.D.key=1 + #no need for 'unknown_dotted' vs 'dottedkey_table' ?? + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedkey_refpath [list {*}$dottedsuper_refpath "@@$dottedtable"] + #our dotted key is attempting to define a table + if {![dict exists $tablenames_info $dottedkey_refpath ttype]} { + #first one - but check datastructure for collisions + if {[tomlish::dict::path::exists $datastructure $dottedkey_refpath]} { + set msg "Path $dottedkey_refpath for dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'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::setleaf datastructure $dottedkey_refpath {} 0 + lappend dottedtables_defined $dottedkey_refpath + + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + set ttype [dict get $tablenames_info $dottedkey_refpath ttype] + set definedstate [dictn getdef $tablenames_info [list $dottedkey_refpath tdefined] NULL] + switch -- $ttype { + dottedkey_table - unknown_dotted { + #'created' as dotted - but make sure it's from this header section - i.e defined not set + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table at $dottedkey_refpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (table redefinition) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } + } + itable { + #itables are immediately defined + set msg "Table at $dottedkey_refpath represented by dottedkey $dottedkeyname has been 'defined' as itable (table redefinition) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } + default { + #header_table, header_tablearray or unknown_header + #is header_tablearray any different from header_table in this context? + #we don't set tdefined for tablearray anyway - so should be ok here. + if {$definedstate ne "NULL"} { + set msg "Table at $dottedkey_refpath represented by dottedkey $dottedkeyname has been 'defined' in a header (table redefinition) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } + } + } + } + } else { + set dottedkey_refpath $dottedsuper_refpath + } + #assert - dottedkey represents a key val pair that can be added + + + set fullkey_refpath [list {*}$dottedkey_refpath @@$leaf_key] + if {[tomlish::dict::path::exists $datastructure $fullkey_refpath]} { + set msg "Duplicate key. The key (path $fullkey_refpath) already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + #set keyval_dict [_get_keyval_value $element] + lassign [_get_keyval_value $element] _ keyval_dict _ sub_tablenames_info + + + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_typeval can distinguish + tomlish::log::debug "_process_tomlish_dottedkey>>> context:$context_refpath dottedkey $dottedkeyname kv: $keyval_dict" + tomlish::dict::path::setleaf datastructure $fullkey_refpath $keyval_dict 0 + + #remove ? + #if {![tomlish::dict::is_typeval $keyval_dict]} { + # #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # # inner structure will contain {type value } if all leaves are not empty ITABLES + # ##set tkey [list {*}$norm_segments {*}$all_dotted_keys] + + # #by not creating a tablenames_info record - we effectively make it closed anyway? + # #it should be detected as a key + # #is there any need to store tablenames_info for it?? + # #REVIEW + + # ##TODO - update? + # #dictn incr tablenames_info [list $tkey seencount] + # ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + # ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + # #dictn set tablenames_info [list $tkey closed] 1 + #} + 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. + # creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. + #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. + # + + #within an ARRAY, we store a list of items such as plain dicts (possibly empty) and {type value } for simple types + #(ARRAYS can be mixed type) + #This means our dict structure should have only ARRAY and simple types which need to be in {type value } form + #A dict within an array encodeded as a type ITABLE value should also parse - but is the unpreferred form - REVIEW test? + + #Namespacing? + #ie note the difference: + #[Data] + #temp = { cpu = 79.5, case = 72.0} + # versus + #[Data] + #temps = [{cpu = 79.5, case = 72.0}] + proc from_tomlish {tomlish {returnextra 0}} { + package require dictn + + #keep track of which tablenames have already been directly defined, + # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' + #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. + #we don't error out just because a previous tablename segment has already appeared. + + #Declaring, Creating, and Defining Tables + #https://github.com/toml-lang/toml/issues/795 + #(update - only Creating and Defining are relevant terminology) + + #review + #tablenames_info keys ttype created, tdefined, createdby, definedby, closedby ??? review keys + # [tname] = header_table [[tname]] = header_tablearray + + #consider the following 2 which are legal: + #[table] #'table' created, defined=open type header_table + #x.y = 3 + #[table.x.z] #'table' tdefined=closed closedby={header_table table.x.z}, 'table.x' created, 'table.x.z' created tdefined=open tdefinedby={header_table table.x.z} + #k= 22 + # #'table.x.z' tdefined=closed closedby={eof eof} + + #equivalent datastructure + + #[table] #'table' created, tdefined=open definedby={header_table table} + #[table.x] #'table' tdefined=closed closedby={header_table table.x}, 'table.x' created tdefined=open definedby={header_table table.x} + #y = 3 + #[table.x.z] #'table.x' tdefined=closed closedby={header_table table.x.z}, 'table.x.z' created tdefined=open definedby={header_table table.x.z} + #k=22 + + #illegal + #[table] #'table' created and tdefined=open + #x.y = 3 #'table.x' created first keyval pair tdefined=open definedby={keyval x.y = 3} + #[table.x.y.z] #'table' tdefined=closed, 'table.x' closed because parent 'table' closed?, 'table.x.y' cannot be created + #k = 22 + # + ## - we would fail on encountering table.x.y because only table and table.x are effectively tables - but that table.x is closed should be detected (?) + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + #note: it is not safe to compare normalized tablenames using join! + # e.g a.'b.c'.d is not the same as a.b.c.d + # instead compare {a b.c d} with {a b c d} + # Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. + #'a.b'.'c.d.e' vs 'a.b.c'.'d.e' + #we need to normalize the tablenames seen so that {"x\ty"} matches {"xy"} + + + + if {[uplevel 1 [list info exists tablenames_info]]} { + upvar tablenames_info tablenames_info + } else { + set tablenames_info [dict create] ;#keyed on tablepath each of which is an @@path such as {@@config @@subgroup @@etc} (corresponding to config.subgroup.etc) + #also has non @@ indexes which are list indexes as taken by tcl list commands (int or end-1 etc) + #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 "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" + } + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + #ignore TOMLISH tag at beginning + set items [lrange $tomlish 1 end] + } + + set datastructure [dict create] + set dottedtables_defined [list] + foreach item $items { + set tag [lindex $item 0] + #puts "...> item:'$item' tag:'$tag'" + switch -exact -- $tag { + KEY - DQKEY - SQKEY - INT - FLOAT - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL - STRING - LITERAL { + #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 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 + + } + TABLEARRAY { + #close off any dottedtables_defined created by dottedkeys at this level + foreach dtablepath $dottedtables_defined { + dict set tablenames_info $dtablepath tdefined closed + } + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + + set tablearrayname [lindex $item 1] + tomlish::log::debug "---> tomlish::dict::from_tomlish processing item TABLENAME (name: $tablearrayname): $item" + set norm_segments [::tomlish::toml::tablename_split $tablearrayname true] ;#true to normalize + #we expect repeated tablearray entries - each adding a sub-object to the value, which is an array/list. + #tablearrayname is likely to appear multiple times - so unlike a TABLE we don't check for 'defined' for the full name as an indicator of a problem + set supertable [list] + ############## + # [[a.b.c.d]] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + set refpath [list] ;#e.g @@j1 @@j2 1 @@k1 end + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + lappend refpath @@$normseg + if {![dict exists $tablenames_info $refpath ttype]} { + #supertable with this path doesn't yet exist + if {[tomlish::dict::path::exists $datastructure $refpath]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of tablearray name $tablearrayname already has data but doesn't appear to be a table - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_supertable_keycollision + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } else { + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + #review - we can't later specify as tablearray so should just set ttype to header_table even though it's being created + # because of a tablearray header? + #By setting ttype to something other than table_header we can provide more precise errorCode/msg ?? + dict set tablenames_info $refpath ttype unknown_header + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } else { + #REVIEW!! + # what happens with from_toml {[[a.b.c]]} {[[a.b]]} ??? + #presumed that a and a.b were 'created' as tables (supertables of tablearray at a.b.c) and can't now be redefined as tablearrays + + #supertable has already been created - and may be defined - but even if defined we can add subtables unless it is of type itable + #but if it's a tablearray - we need to point to the most 'recently defined table element of the array' + #(last member of that array - need to check type? allowed to have non-table elements ie nonhomogenous??) + set supertype [dict get $tablenames_info $refpath ttype] + if {$supertype eq "header_tablearray"} { + #exercised by toml-tests: + # valid/table/array-table-array + # valid/table/array-nest + + #puts stdout "todict!!! TABLEARRAY nesting required for supertable [join $supertable .]" + + #'refer' to the appropriate element in existing array + set arrdata [tomlish::dict::path::get $datastructure [list {*}$refpath @@value]] + set idx [expr {[llength $arrdata]-1}] + if {$idx < 0} { + #existing tablearray should have at least one entry even if empty (review) + set msg "reference to empty tablearray?" + return -code error -errorcode {TOMLISH STRUCTURE REFTOEMPTYTABLEARRAY} $msg + } + lappend refpath $idx + } + } + } + # + #puts "TABLE supertable refpath $refpath" + lappend refpath @@[lindex $norm_segments end] + tomlish::log::debug "TABLEARRAY refpath $refpath" + set tablearray_refpath $refpath + + + if {![dict exists $tablenames_info $tablearray_refpath ttype]} { + #first encounter of this tablearrayname + if {[tomlish::dict::path::exists $datastructure $tablearray_refpath]} { + #e.g from_toml {a=1} {[[a]]} + set msg "Cannot create tablearray name $tablearrayname. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_direct_keycollision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no collision - we can create the tablearray and the array in the datastructure + 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::setleaf datastructure $tablearray_refpath [list type ARRAY value {{}}] 0 + set arrayitem_refpath [list {*}$tablearray_refpath 0] + #set ARRAY_ELEMENTS [list] + } else { + #we have an existing tablenames_info record for this path - but is it a tablearray? + set ttype [dict get $tablenames_info $tablearray_refpath ttype] + if {$ttype ne "header_tablearray"} { + #header_table or itable + switch -- $ttype { + itable {set ttypename itable} + header_table {set ttypename table} + dottedkey_table {set ttypename dottedkey_table} + unknown_header - unknown_dotted { + #table was created e.g as supertable - but not specifically a tablearray + #violates ordering - return specific test error + set msg "Table $tablearrayname referenced as supertable before tablearray defined (ordering)" + return -code error -errorcode {TOMLISH STRUCTURE TABLEARRAYORDERING} $msg + } + default {error "unrecognised type $ttype - expected header_table or itable"} + } + set msg "tablearray name $tablearrayname already appears to be already created as '$ttypename' not tablearray - invalid?" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #EXISTING tablearray + #add to array + #error "add_to_array not implemented" + #{type ARRAY value } + #set ARRAY_ELEMENTS [dict get $datastructure {*}$norm_segments value] + tomlish::log::debug ">>>>pre-extend-array dict::from_tomlish datastructure: $datastructure" + set existing_array [tomlish::dict::path::get $datastructure [list {*}$tablearray_refpath @@value]] + set arrayitem_refpath [list {*}$tablearray_refpath [llength $existing_array]] + tomlish::dict::path::lappend datastructure $tablearray_refpath {} + tomlish::log::debug ">>>>post-extend-array dict::from_tomlish datastructure: $datastructure" + } + + + #set object [dict create] ;#array context equivalent of 'datastructure' + + #add to ARRAY_ELEMENTS and write back in to datastructure. + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + tomlish::log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkinfo [_process_tomlish_dottedkey $element $arrayitem_refpath] + lappend dottedtables_defined {*}[dict get $dkinfo dottedtables_defined] + } + NEWLINE - COMMENT - WS { + #ignore + } + TABLE { + #we *perhaps* should be able to process tablearray subtables either as part of the tablearray record, or independently. + #(or even a mixture of both, although that is somewhat an edge case, and of limited utility) + #[[fruit]] + #x=1 + # [fruit.metadata] + # [fruit.otherdata] + + #when processing a dict destined for the above - the tomlish generator (e.g from_dict) + #should create as 1 or 3 records (but could create 2 records if there was an unrelated table in between the subtables) + #choices: all in tablearray record, tablearray + 1 or 2 table records. + # + #We are going the other way here - so we just need to realise that the list of tables 'belonging' to this tablearray might not be complete. + # + #the subtable names must be prefixed with the tablearray - we should validate that for any contained TABLE records + + #The default mechanism is for from_dict to produce tomlish with separate TABLE records - and use the ordering to determine membership + #If we were to support wrapping the TABLE records within a TABLEARRAY - we should also support TABLEARRAY within TABLEARRAY + # ----------------------------------------------------------------------- + #Implementing this is not critical for standard encoding/decoding of toml! + #It would be an alternative form for the tomlish intermediate form - and adds complexity. + # + #The upside would be to provide a function for sorting/rearranging in the tomlish form if all records were fully encapsulated. + #A possible downside is that unrelated tables placed before a tablearray is fully defined (within the tablearray definition area in toml) + # would have to be re-positioned before or after the encapsulated tablearray record. + # While unrelated tables in such a position aren't a recommended way to write toml, they appear to be valid + # and preserving the author's ordering is a goal of the basic encoding/decoding operations if no explicit sorting/reordering was requested. + # + #Consider an 'encapsulate' method to this (tomlish -> tomlish) + # ----------------------------------------------------------------------- + #todo + error "tomlish::dict::from_tomlish TABLE element within TABLEARRAY not handled - TABLE should be a separate tomlish record" + } + default { + error "tomlish::dict::from_tomlish Sub element of type '$type' not understood in tablearray context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + + #end of TABLEARRAY record - equivalent of EOF or next header - close off the dottedtables + foreach dtablepath $dottedtables_defined { + dict set tablenames_info $dtablepath tdefined closed + } + } + TABLE { + #close off any dottedtables_defined created by dottedkeys at this level + foreach dtablepath $dottedtables_defined { + dict set tablenames_info $dtablepath tdefined closed + } + set tablename [lindex $item 1] + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + #As our TABLE record contains all it's child DOTTEDKEY records - this should be equivalent to setting them as defined at EOF or next header. + + #----------------------------------------------------------------------------------- + #default assumption - our reference is to the main tablenames_info and datastructure + #Will need to append keys appropriately if we have recursed + #----------------------------------------------------------------------------------- + + log::debug "---> tomlish::dict::from_tomlish processing item TABLE (name: $tablename): $item" + set norm_segments [::tomlish::toml::tablename_split $tablename true] ;#true to normalize + + + + set name_segments [::tomlish::toml::tablename_split $tablename 0] ;#unnormalized e.g ['a'."b".c.d] -> 'a' "b" c d + #results of tablename_split 0 are 'raw' - ie some segments may be enclosed in single or double quotes. + + + set supertable [list] + ############## + # [a.b.c.d] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + + ############## + #[[a]] + #[a.b] #supertable a is tablearray + ############## + + #also consider + ############## + # [[a.b]] + # [a.b.c.d] #supertable a is a table, supertable a.b is tablearray, supertable a.b.c is elementtable + ############## + set refpath [list] ;#e.g @@j1 @@j2 1 @@k1 end + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + lappend refpath @@$normseg + if {![dict exists $tablenames_info $refpath ttype]} { + #supertable with this path doesn't yet exist + if {[tomlish::dict::path::exists $datastructure $refpath]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of table name $tablename (path $refpath) already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + #we also don't know whether it's a table or a dottedkey_table (not allowed to be tablearray - out of order?) + 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::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"} { + #'refer' to the appropriate element in existing array + set arrdata [tomlish::dict::path::get $datastructure [list {*}$refpath @@value]] + set idx [expr {[llength $arrdata]-1}] + if {$idx < 0} { + #existing tablearray should have at least one entry even if empty (review) + set msg "reference to empty tablearray?" + return -code error -errorcode {TOMLISH STRUCTURE REFTOEMPTYTABLEARRAY} $msg + } + lappend refpath $idx + } else { + #?? + if {[dictn getdef $tablenames_info [list $refpath tdefined] NULL] eq "NULL"} { + } else { + } + } + } + } + #puts "TABLE supertable refpath $refpath" + lappend refpath @@[lindex $norm_segments end] + tomlish::log::info "TABLE refpath $refpath" + set table_refpath $refpath + + + + + #table [a.b.c.d] hasn't been defined - but may have been 'created' already by a longer tablename + # - or may have existing data from a keyval + if {![dict exists $tablenames_info $table_refpath ttype]} { + if {[tomlish::dict::path::exists $datastructure $table_refpath]} { + #e.g from_toml {a=1} {[a]} + set msg "Cannot create table name $tablename. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablename_keyval_collision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no data or previously created table + dict set tablenames_info $table_refpath ttype header_table + + #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::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 + #[[tbl]] + #[tbl] + set msg "Table name $tablename has already been created as a tablearray. Invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } else { + #any other type tdefined is a problem + set T_DEFINED [dictn getdef $tablenames_info [list $table_refpath tdefined] NULL] + if {$T_DEFINED ne "NULL" } { + #our tablename e.g [a.b.c.d] declares a space to 'define' subkeys - but there has already been a definition space for this path + set msg "Table name $tablename has already been defined in the toml data. Invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } + } + } + dict set tablenames_info $table_refpath tdefined open + + #now add the contained elements + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkinfo [_process_tomlish_dottedkey $element $table_refpath] + lappend dottedtables_defined {*}[dict get $dkinfo dottedtables_defined] + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in table context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + + #end of TABLE record - equivalent of EOF or next header - close off the dottedtables + foreach dtablepath $dottedtables_defined { + dict set tablenames_info $dtablepath tdefined closed + } + } + ITABLE { + #As there is no other mechanism to create tables within an ITABLE than dottedkeys + # and ITABLES are fully defined/enclosed - we can rely on key collision and don't need to track dottedtables_defined - REVIEW. + set dottedtables_defined [list] + #SEP??? + #ITABLE only ever on RHS of = or inside ARRAY + set datastructure [dict create] + set tablenames_info [dict create] + + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkinfo [_process_tomlish_dottedkey $element] + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + } + ARRAY { + #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" + + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME - DATETIME-LOCAL - DATE-LOCAL - TIME-LOCAL { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + STRING { + #JJJJ + #don't unescape string! + set value [lindex $element 1] + #lappend datastructure [list type $type value [::tomlish::utils::unescape_string $value]] + lappend datastructure [list type $type value $value] + } + LITERAL { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + ITABLE { + #anonymous table + #lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + lappend datastructure [::tomlish::dict::from_tomlish [list $element]] ;#store itables within arrays as raw dicts (possibly empty) + } + TABLE - TABLEARRAY { + #invalid? shouldn't be output from from_dict - but could manually be constructed as such? review + #doesn't make sense as table needs a name? + #take as synonym for ITABLE? + error "tomlish::dict::from_tomlish $type within array unexpected" + } + ARRAY - MULTISTRING - MULTILITERAL { + #set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::dict::from_tomlish [list $element]]] + } + WS - SEP - NEWLINE - COMMENT { + #ignore whitespace, commas, newlines and comments + } + default { + error "tomlish::dict::from_tomlish Unexpected value type '$type' found in array" + } + } + } + } + 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) + #All whitespace other than newlines is within LITERALPARTS + # ------------------------------------------------------------------------- + #todo - consider extension to toml to allow indent-aware multiline literals + # how - propose as issue in toml github? Use different delim? e.g ^^^ ? + #e.g + # xxx=?'''abc + # def + # etc + # ''' + # - we would like to trimleft each line to the column following the opening delim + # ------------------------------------------------------------------------- + + log::debug "---> todict processing multiliteral: $item" + set parts [lrange $item 1 end] + if {[lindex $parts 0 0] eq "NEWLINE"} { + set parts [lrange $parts 1 end] ;#skip it + } + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + switch -exact -- $type { + LITERALPART { + append stringvalue [lindex $element 1] + } + NEWLINE { + set val [lindex $element 1] + if {$val eq "lf"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + 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 "" + set idx 0 + set parts [lrange $item 1 end] + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + #We use STRINGPART in the tomlish representation as a distinct element to STRING - which would imply wrapping quotes to be reinserted + switch -exact -- $type { + STRING { + #todo - do away with STRING ? + #we don't build MULTISTRINGS containing STRING - but should we accept it? + tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" + #append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" + append stringvalue "\"[lindex $element 1]\"" + } + STRINGPART { + #JJJ + #don't unescape string + #append stringvalue [::tomlish::utils::unescape_string [lindex $element 1]] + append stringvalue [lindex $element 1] + } + CONT { + #When the last non-whitespace character on a line is an unescaped backslash, + #it will be trimmed along with all whitespace (including newlines) up to the next non-whitespace character or closing delimiter + # review - we allow some whitespace in stringpart elements - can a stringpart ever be all whitespace? + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last (or first and only) line + return -code error -errorcode {TOMLISH SYNTAX INVALIDESCAPE} "Invalid whitespace escape - not a valid continuation position" + #set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + #if {$non_ws >= 0} { + # #append stringvalue "\\" + # return -code error -errorcode {TOMLISH SYNTAX INVALIDESCAPE} "Invalid whitespace escape - not a valid continuation position" + #} else { + # #skip over ws without emitting + # set idx [llength $parts] + #} + } else { + set parts_til_nl [lrange $parts 0 $next_nl-1] + set non_ws [lsearch -index 0 -start $idx+1 -not $parts_til_nl WS] + if {$non_ws >= 0} { + #This CONT is invalid. If there had been a non-whitespace char directly following it, + #it wouldn't have come through as a CONT token + #Now that we see it isn't the last non-whitespace backslash on the line we can reject + # as an invalid escape of space or tab + #append stringvalue "\\" + return -code error -errorcode {TOMLISH SYNTAX INVALIDESCAPE} "Invalid whitespace escape - not a valid continuation position" + } else { + #skip over ws on this line + set idx $next_nl + #then have to check each subsequent line until we get to first non-whitespace + set trimming 1 + while {$trimming && $idx < [llength $parts]} { + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + } else { + set idx [llength $parts] + } + set trimming 0 + } else { + set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + set trimming 0 + } else { + set idx $next_nl + #keep trimming + } + } + } + } + } + } + NEWLINE { + #if newline is first element - it is not part of the data of a multistring + if {$idx > 0} { + set val [lindex $element 1] + if {$val eq "lf"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + } + WS { + append stringvalue [lindex $element 1] + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + WS - COMMENT - NEWLINE { + #ignore + } + BOM { + #this token is the unicode single char \uFFEF + #It doesn't tell us what encoding was originally used (though toml should only accept UTF-8 files) + #ignore at start - what about in other positions? + } + default { + error "Unexpected tag '$tag' in Tomlish list '$tomlish'" + } + } + } + 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 + 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 } + + 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 { + #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] + } + } + 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 { + #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] + } + } + } + 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'" + } + } + 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'" + } + } + 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'" + } + } + } + + #a restricted analogy of 'dictn set' + #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 + + + # vscode tcl syntax highlighter is unable to handle (in some cases!) some simple constructs like left square bracket in curly braces, + # yet it is ok in comments. i.e {[} is prolematic for the highlighter, so we use "\[" instead :/ + #e.g ------------------------------------------------ + # if {[string index $path 0] in [list . {[}] } { + # # ... + # } + # ------------------------------------------------ + #This may highlight ok - and even text immediately following can be ok - but + # the subsequent code block at global scope, perhaps *many* lines distant from where the syntax highlighting issue started, may then be completely miscoloured + # This is a big timewaster - a decent syntax highlighter is really needed for Tcl in vscode (2025-09) + + 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::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 + if {[string range $p 0 1] eq "@@"} { + ::set k [string range $p 2 end] + + # if {![dict exists $data $k]} { + # error "tomlish::dict:path::set error bad path $path. Attempt to access nonexistent element at subpath $pathsofar." + # } + ::set varname v[incr v] + + 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::setleaf error Unable to overwrite subpath '$pathsofar' which is of type $existing_tp with sub-dict. Supplied value not {type value 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::setleaf error bad path '$path'. Cannot overwrite array with non-array: $value" + } + } + default { + # + } + } + } else { + #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::setleaf error path '$path'. Cannot overwrite sub-dict (size: [dict size $endpoint]) with non sub-dict: $value" + } + } + ::set $varname $value + dict set vdict $pathsofar $varname + break + } else { + ::set arrdata [dict get $data value] + set idx [tomlish::system::lindex_resolve_basic $arrdata $p] + if {$idx == -1} { + error "tomlish::dict::path::setleaf error bad path '$path'. No existing element at $p" + } + ::set data [lindex $arrdata $p] + ::set $varname $data + dict set vdict $pathsofar $varname + } + } + } + #dict for {path varname} $vdict { + # puts "$path $varname\n" + # puts " '[::set $varname]'\n" + # puts "" + #} + + ::set i 0 + ::set reverse [lreverse $vdict] + foreach {varname path} $reverse { + set newval [::set $varname] + if {$i+2 == [llength $reverse]} { + ::set k [lindex $path end] + ::set k [string range $k 2 end] ;#first key is always @@something + dict set dict_being_edited $k $newval + #puts "--result $dict_being_edited" + break + } + ::set nextvarname [lindex $reverse $i+2] + ::set nextval [::set $nextvarname] + ::set k [lindex $path end] + if {[string match @@* $k]} { + #dict key + #dict set $nextvarname $k $newval + setleaf $nextvarname [list $k] $newval 0 + } else { + #list index + ::set nextarr [dict get $nextval value] + ::lset nextarr $k $newval + dict set $nextvarname value $nextarr + } + ::incr i 2 + } + + return $dict_being_edited + + } + #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] + #::set newlist [list] + ::set v 0 + ::set vdict [dict create] + foreach a $args { + 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" + } + } + foreach p $path { + ::lappend pathsofar $p + if {[string range $p 0 1] eq "@@"} { + ::set k [string range $p 2 end] + if {![dict exists $data $k]} { + error "tomlish::dict::path::lappend error bad path $path. Attempt to access nonexistent element at subpath $pathsofar." + } + ::set varname v[incr v] + + 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]} { + error "tomlish::dict::path::lappend error bad path $path. Attempt to access table as array at subpath $pathsofar." + } + if {[dict get $endpoint type] ne "ARRAY"} { + error "tomlish::dict::path::lappend error bad path $path. Subpath $pathsofar is not an array." + } + ::set arrdata [dict get $endpoint value] + ::lappend arrdata {*}$args + dict set endpoint value $arrdata + ::set newlist $endpoint + ::set $varname $newlist + dict set vdict $pathsofar $varname + break + } + ::set data [dict get $data $k] + ::set $varname $data + dict set vdict $pathsofar $varname + } else { + if {![tomlish::dict::is_typeval $data]} { + error "tomlish::dict::path::lappend error bad path $path. Attempt to access table as array at subpath $pathsofar." + } + if {[dict get $data type] ne "ARRAY"} { + error "tomlish::dict::path::lappend error bad path $path. Subpath $pathsofar is not an array." + } + ::set varname v[incr v] + 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." + } + ::set parentarray [dict get $data value] + ::set idx [tomlish::system::lindex_resolve_basic $parentarray $p] + if {$idx == -1} { + error "tomlish::dict::path::lappend error bad path $path. Index $p does not exist." + } + ::set endpoint [lindex $parentarray $p] + if {[dict get $endpoint type] ne "ARRAY"} { + error "tomlish::dict::path::lappend error bad path $path. Not an array." + } + + ::set arrdata [dict get $endpoint value] + ::lappend arrdata {*}$args + dict set endpoint value $arrdata + ::set newlist $endpoint + #::lset parentarray $p $newlist + #set parentarray $newlist + ::set $varname $newlist + dict set vdict $pathsofar $varname + break + } else { + ::set arrdata [dict get $data value] + set idx [tomlish::system::lindex_resolve_basic $arrdata $p] + if {$idx == -1} { + error "tomlish::dict::path::lappend error bad path $path. Subpath $pathsofar, index $p does not exist." + } + ::set data [lindex $arrdata $p] + ::set $varname $data + dict set vdict $pathsofar $varname + } + } + } + # todo tomlish::log::debug ? + # dict for {path varname} $vdict { + # puts "$path $varname\n" + # puts " [::set $varname]\n" + # puts "" + # } + ::set i 0 + ::set reverse [lreverse $vdict] + foreach {varname path} $reverse { + set newval [::set $varname] + if {$i+2 == [llength $reverse]} { + ::set k [lindex $path end] + ::set k [string range $k 2 end] ;#first key is always @@something + dict set dict_being_edited $k $newval + #puts "--result $dict_being_edited" + break + } + ::set nextvarname [lindex $reverse $i+2] + ::set nextval [::set $nextvarname] + ::set k [lindex $path end] + if {[string match @@* $k]} { + #dict key + set k [string range $k 2 end] + dict set $nextvarname $k $newval + } else { + #list index + ::set nextarr [dict get $nextval value] + ::lset nextarr $k $newval + dict set $nextvarname value $nextarr + } + ::incr i 2 + } + return $dict_being_edited + } +} + +tcl::namespace::eval tomlish::to_dict { + + proc @@path {dictkeys} { + lmap v $dictkeys {string cat @@ $v} + } + +} + +tcl::namespace::eval tomlish::app { + #*** !doctools + #[subsection {Namespace tomlish::app}] + #[para] + #[list_begin definitions] + + tcl::namespace::eval argdoc { + proc test_suites {} { + if {[package provide test::tomlish] eq ""} { + return [list] + } + return [test::tomlish::SUITES] + } + } + + package require punk::args + punk::args::define { + @id -id ::tomlish::app::decode_to_typedjson + @cmd -name tomlish::app::decode_to_typedjson -help\ + "Read toml on stdin until EOF + on error - returns non-zero exit code and writes error to + the errorchannel. + on success - returns zero exit code and writes typed JSON encoding + of the data to the outputchannel. + This decoder is intended to be compatble with toml-test. + toml-test defines the typed JSON format." + @leaders -min 0 -max 0 + @opts + -help -type none -help\ + "Display this usage message" + -inputchannel -default stdin + -inputencoding -default "iso8859-1" -choicerestricted 0 -choices {utf-8 utf-16 iso8859-1} -help\ + "configure encoding on input channel + iso8859-1 is equivalent to binary encoding" + -outputchannel -default stdout + -errorchannel -default stderr + @values -min 0 -max 0 + } + proc decode_to_typedjson {args} { + set argd [punk::args::parse $args withid ::tomlish::app::decode_to_typedjson] + set ch_input [dict get $argd opts -inputchannel] + set ch_input_enc [dict get $argd opts -inputencoding] + set ch_output [dict get $argd opts -outputchannel] + set ch_error [dict get $argd opts -errorchannel] + if {[dict exists $argd received -help]} { + return [punk::args::usage -scheme info ::tomlish::app::decode_to_typedjson] + } + + chan configure $ch_input -encoding $ch_input_enc + #translation? + chan configure $ch_input -translation lf ;# toml-test invalid/control tests we need to see raw CRs to reject them properly - auto translation won't do. + + #Just slurp it all - presumably we are not handling massive amounts of data on stdin. + # - even if the input is large, we probably don't gain much (aside from possible memory savings?) by attempting to process input as it arrives. + if {[catch { + set inputdata [read $ch_input] + if {$ch_input_enc eq "iso8859-1"} { + set toml [tomlish::toml::from_binary $inputdata] + } else { + set toml $inputdata + } + } errM]} { + puts stderr "read-input error: $errM" + #toml-tests expect exit code 1 + #e.g invalid/encoding/utf16-bom + exit 1 ;#read error + } + try { + set j [::tomlish::toml_to_typedjson $toml] + } on error {em} { + puts $ch_error "decoding failed: '$em'" + exit 1 + } + puts -nonewline $ch_output $j + exit 0 + } + + package require punk::args + punk::args::define { + @id -id ::tomlish::app::encode_from_typedjson + @cmd -name tomlish::app::encode_from_typedjson -help\ + "Read typed JSON on input until EOF + return non-zero exitcode if JSON data cannot be converted to + a valid TOML representation. + return zero exitcode and TOML data on output if JSON data can + be converted. + This encoder is intended to be compatible with toml-test. + toml-test defines the typed JSON format." + @leaders -min 0 -max 0 + @opts + -help -type none -help \ + "Display this usage message" + -restrict_barekeys -default 0 -help\ + "If true, keys containing unicode will be quoted. + If false, an extended range of barekeys will be used + in unquoted form." + -inputchannel -default stdin + -inputencoding -default "" -choicerestricted 0 -choices {utf-8 utf-16 iso8859-1} -help\ + "configure encoding on input channel + If not supplied, leave at Tcl default" + -outputchannel -default stdout + -errorchannel -default stderr + @values -min 0 -max 0 + } + proc encode_from_typedjson {args} { + set argd [punk::args::parse $args withid ::tomlish::app::encode_from_typedjson] + set restrict_barekeys [dict get $argd opts -restrict_barekeys] + set ch_input [dict get $argd opts -inputchannel] + set ch_input_enc [dict get $argd opts -inputencoding] + set ch_output [dict get $argd opts -outputchannel] + set ch_error [dict get $argd opts -errorchannel] + if {[dict exists $argd received -help]} { + return [punk::args::usage -scheme info ::tomlish::app::encode_from_typedjson] + } + #review + if {$ch_input_enc ne ""} { + chan configure $ch_input -encoding $ch_input_enc + } + #review + chan configure $ch_input -translation lf + + chan configure $ch_output -translation lf + + if {[catch { + set json [read $ch_input] + }]} { + exit 2 ;#read error + } + try { + #tomlish::typedjson_to_toml + set toml [::tomlish::toml::from_tomlish_from_dict_from_typedjson $json] + } trap {} {e eopts} { + puts $ch_error "encoding failed: '$e'" + puts $ch_error "$::errorInfo" + exit 1 + } + puts -nonewline $ch_output $toml + exit 0 + } + + punk::args::define { + @dynamic + @id -id ::tomlish::app::test + @cmd -name tomlish::app::test -help\ + "Run the internal tests on the tomlish library." + @leaders + @opts -any 1 + -help -type none -help\ + "Display this usage message + or further info if more args." + -suite -default tests -choices {${[::tomlish::app::argdoc::test_suites]}} + @values -min 0 -max -1 + } + proc test {args} { + package require test::tomlish + set argd [punk::args::parse $args withid ::tomlish::app::test] + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + set solos [dict get $argd solos] + set opt_suite [dict get $opts -suite] + if {[dict exists $received -help] && ![dict exists $received -suite]} { + return [punk::args::usage -scheme info ::tomlish::app::test] + } + + test::tomlish::SUITE $opt_suite + #if {[catch {test::tomlish::SUITE $opt_suite} errM]} { + # puts stderr "Unknown test suite '$opt_suite'. Available suites: [test::tomlish::SUITES]" + # exit 1 + #} + set run_opts [dict remove $opts -suite] + set run_opts [dict remove $run_opts {*}$solos] + set result [test::tomlish::RUN {*}$run_opts {*}$solos {*}$values] + return $result + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::app ---}] +} + +proc ::tomlish::appnames {} { + set applist [list] + foreach cmd [info commands ::tomlish::app::*] { + lappend applist [namespace tail $cmd] + } + return $applist +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace tomlish::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish::system { + #*** !doctools + #[subsection {Namespace tomlish::system}] + #[para] + #[list_begin definitions] + + + + #taken from punk::lib + #todo - change list argument to integer length + proc lindex_resolve_basic {list index} { + #*** !doctools + #[call [fun lindex_resolve_basic] [arg list] [arg index]] + #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) + #[para] returns -1 for out of range at either end, or a valid integer index + #[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound + #[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command + #[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1 + #[para] For pure integer indices the performance should be equivalent + + set 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 + if {$index < 0 || ($index >= [llength $list])} { + #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. + return -1 + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } + if {[llength $list]} { + set indices [tomlish::system::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. + #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) + } else { + set indices [list] + } + set idx [lindex $indices $index] + if {$idx eq ""} { + #we have no way to determine if out of bounds is at lower vs upper end + return -1 + } else { + return $idx + } + } + + #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 + #support minimal set from to + proc range {from to} { + lseq $from $to + } + } else { + #lseq accepts basic expressions e.g 4-2 for both arguments + #e.g we can do lseq 0 [llength $list]-1 + #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. + proc range {from to} { + set to [offset_expr $to] + set from [offset_expr $from] + if {$to > $from} { + set count [expr {($to -$from) + 1}] + if {$from == 0} { + return [lsearch -all [lrepeat $count 0] *] + } else { + incr from -1 + return [lmap v [lrepeat $count 0] {incr from}] + } + #slower methods. + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from] + #} + #return $L + } elseif {$from > $to} { + set count [expr {$from - $to} + 1] + #1) + if {$to == 0} { + return [lreverse [lsearch -all [lrepeat $count 0] *]] + } else { + incr from + return [lmap v [lrepeat $count 0] {incr from -1}] + } + + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from -1];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from -1] + #} + #return $L + } else { + return [list $from] + } + } + } + + proc is_main_script {} { + #maint - from punk::lib::is_main_script + #see https://wiki.tcl-lang.org/page/main+script + if {[info script] ne "" && [info exists ::argv0] + && + [file dirname [file normalize [file join [info script] ...]]] + eq + [file dirname [file normalize [file join $::argv0 ...]]] + } { + return true + } else { + return false + } + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::system ---}] +} + + +# if {[info exists ::argc] && $::argc > 0} {} ;#not a valid way to test if main script + +if {[tomlish::system::is_main_script]} { + #puts stderr "argc: $::argc args: $::argv" + set arglist $::argv + # -------------- + #make sure any dependant packages that are sourced don't get any commandline args + set ::argv {} + set ::argc 0 + # -------------- + package require punk::args + punk::args::define { + @id -id tomlish::cmdline + @cmd -name tomlish -help\ + "toml encoder/decoder written in Tcl" + @opts -any 1 + -help -type none -help\ + "Display this usage message or more specific + help if further arguments provided." + -app -choices {${[tomlish::appnames]}} + } + try { + set argd [punk::args::parse $arglist withid tomlish::cmdline] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + puts stderr $msg + exit 1 + } + + + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received -help] && ![dict exists $received -app]} { + #only emit cmdline help if -app not supplied as well - otherwise app function can act on -help for more specific help + #puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + puts stdout [punk::args::usage -scheme info tomlish::cmdline] + exit 0 + } + if {![dict exists $received -app]} { + puts stderr [punk::args::usage -scheme error tomlish::cmdline] + exit 1 + } + + set app [dict get $opts -app] + set appnames [tomlish::appnames] + set app_opts [dict remove $opts -app {*}$solos] + try { + set result [tomlish::app::$app {*}$app_opts {*}$solos {*}$values] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + #The validation error should fully describe the issue + #no need for errortrace - keep the output cleaner + puts stderr $msg + exit 1 + } trap {} {msg erroropts} { + #unexpected error - uncaught throw will produce error trace + #todo - a support msg? Otherwise we may as well just leave off this trap. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + if {"-help" in $solos} { + puts stderr $result + exit 1 + } else { + if {$result ne ""} { + puts stdout $result + exit 0 + } + } +} + +## Ready +package provide tomlish [namespace eval tomlish { + variable pkg tomlish + variable version + set version 1.1.8 +}] +return + +#*** !doctools +#[manpage_end] +