You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
5680 lines
271 KiB
5680 lines
271 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-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.2 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin tomlish_module_tomlish 0 1.1.2] |
|
#[copyright "2024"] |
|
#[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] |
|
#[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] A further goal is to allow at least a useful subset of in-place editing operations which also preserve whitespace and comments. |
|
#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions |
|
#[para] The API for editing (tomldoc object?) may require explicit setting of type if accessing an existing key |
|
#[para] e.g setting a key that already exists and is a different type (especially if nested structure such as a table or array) |
|
#[para] will need a -type option (-force ?) to force overriding with another type such as an int. |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of tomlish |
|
#[subsection Concepts] |
|
#[para] - |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by tomlish |
|
#[list_begin itemized] |
|
|
|
package require Tcl 8.6- |
|
package require struct::stack |
|
package require logger |
|
|
|
#*** !doctools |
|
#[item] [package {Tcl 8.6-}] |
|
#[item] [package {struct::stack}] |
|
|
|
#limit ourselves to clear, destroy, peek, pop, push, rotate, or size (e.g v 1.3 does not implement 'get') |
|
|
|
|
|
#*** !doctools |
|
#[list_end] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section API] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Base namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval tomlish { |
|
namespace export {[a-z]*}; # Convention: export all lowercase |
|
variable types |
|
|
|
#IDEAS: |
|
# since get_toml produces tomlish with whitespace/comments intact: |
|
# tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace |
|
# - setKey (set leaf only to value) how to specify type? -type option? - whole array vs index into arrays and further nested objects? - option for raw toml additions? |
|
# - separate addKey?? |
|
# - deleteKey (delete leaf) |
|
# - deleteTable (delete table - if only has leaves? - option to delete with child tables?) |
|
# - set/add Table? - position in doc based on existing tables/subtables? |
|
|
|
#The tomlish intermediate representation allows things such as sorting the toml document by table name or other re-ordering of tables - |
|
# because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. |
|
#The same goes for the first newline following a keyval e.g x=1 \ny=2\n\n |
|
#The newline is part of the keyval structure so makes reordering easier |
|
#example from_toml "a=1\nb=2\n\n\n" |
|
# 0 = TOMLISH |
|
# 1 = KEY a = {INT 1} {NEWLINE lf} |
|
# 2 = NEWLINE lf |
|
# 3 = KEY b = {INT 2} {NEWLINE lf} |
|
# 4 = NEWLINE lf |
|
# 5 = NEWLINE lf |
|
|
|
|
|
#ARRAY is analogous to a Tcl list |
|
#TABLE is analogous to a Tcl dict |
|
#WS = inline whitespace |
|
#KEY = bare key and value |
|
#QKEY = double quoted key and value ;#todo - rename to DQKEY? |
|
#SQKEY = single quoted key and value |
|
#ITABLE = inline table (*can* be anonymous table) |
|
# inline table values immediately create a table with the opening brace |
|
# inline tables are fully defined between their braces, as are dotted-key subtables defined within |
|
# No additional subtables or arrays of tables may be defined within an inline table after the ending brace - they must be entirely self-contained |
|
|
|
set tags [list TOMLISH ARRAY TABLE ITABLE ANONTABLE WS NEWLINE COMMENT DOTTEDKEY KEY QKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME] |
|
#tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) |
|
#we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) |
|
set min_int -9223372036854775808 ;#-2^63 |
|
set max_int +9223372036854775807 ;#2^63-1 |
|
|
|
proc Dolog {lvl txt} { |
|
#return "$lvl -- $txt" |
|
set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] tomlish '$txt'" |
|
puts stderr $msg |
|
} |
|
logger::initNamespace ::tomlish |
|
foreach lvl [logger::levels] { |
|
interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl |
|
log::logproc $lvl tomlish_log_$lvl |
|
} |
|
|
|
#*** !doctools |
|
#[subsection {Namespace tomlish}] |
|
#[para] Core API functions for tomlish |
|
#[list_begin definitions] |
|
|
|
proc tags {} { |
|
return $::tomlish::tags |
|
} |
|
|
|
#helper function for to_dict |
|
proc _get_keyval_value {keyval_element} { |
|
log::notice ">>> _get_keyval_value from '$keyval_element'<<<" |
|
set found_value 0 |
|
#find the value |
|
# 3 is the earliest index at which the value could occur (depending on whitespace) |
|
set found_sub [list] |
|
if {[lindex $keyval_element 2] ne "="} { |
|
error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured {<keytype> <keydata> = <valuedat>} list" |
|
} |
|
foreach sub [lrange $keyval_element 2 end] { |
|
#note that a barekey/quotedkey won't occur directly inside a barekey/quotedkey |
|
switch -exact -- [lindex $sub 0] { |
|
STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - TABLE - ARRAY - ITABLE { |
|
set type [lindex $sub 0] |
|
set value [lindex $sub 1] |
|
set found_sub $sub |
|
incr found_value 1 |
|
} |
|
default {} |
|
} |
|
} |
|
if {!$found_value} { |
|
error "tomlish Failed to find value element in KEY. '$keyval_element'" |
|
} |
|
if {$found_value > 1} { |
|
error "tomlish Found multiple value elements in KEY, expected exactly one. '$keyval_element'" |
|
} |
|
|
|
switch -exact -- $type { |
|
INT - FLOAT - BOOL - DATETIME { |
|
#simple (non-container, no-substitution) datatype |
|
set result [list type $type value $value] |
|
} |
|
STRING - STRINGPART { |
|
set result [list type $type value [::tomlish::utils::unescape_string $value]] |
|
} |
|
LITERAL - LITERALPART { |
|
#REVIEW |
|
set result [list type $type value $value] |
|
} |
|
TABLE { |
|
#invalid? |
|
error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" |
|
} |
|
ITABLE { |
|
#This one should not be returned as a type <tag> value <something> structure! |
|
# |
|
set result [::tomlish::to_dict [list $found_sub]] |
|
} |
|
ARRAY { |
|
#we need to recurse to get the corresponding dict for the contained item(s) |
|
#pass in the whole $found_sub - not just the $value! |
|
set result [list type $type value [::tomlish::to_dict [list $found_sub]]] |
|
} |
|
MULTISTRING - MULTILITERAL { |
|
#review - mapping these to STRING might make some conversions harder? |
|
#if we keep the MULTI<type> - we know we have to look for newlines for example when converting to json |
|
#without specific types we'd have to check every STRING - and lose info about how best to map chars within it |
|
set result [list type $type value [::tomlish::to_dict [list $found_sub]]] |
|
} |
|
default { |
|
error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" |
|
} |
|
} |
|
return $result |
|
} |
|
|
|
proc _get_dottedkey_info {dottedkeyrecord} { |
|
set key_hierarchy [list] |
|
set key_hierarchy_raw [list] |
|
if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { |
|
error "tomlish _get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" |
|
} |
|
set compoundkeylist [lindex $dottedkeyrecord 1] |
|
set expect_sep 0 |
|
foreach part $compoundkeylist { |
|
set parttag [lindex $part 0] |
|
if {$parttag eq "WS"} { |
|
continue |
|
} |
|
if {$expect_sep} { |
|
if {$parttag ne "DOTSEP"} { |
|
error "DOTTEDKEY missing dot separator between parts. '$dottedkeyrecord'" |
|
} |
|
set expect_sep 0 |
|
} else { |
|
set val [lindex $part 1] |
|
switch -exact -- $parttag { |
|
KEY { |
|
lappend key_hierarchy $val |
|
lappend key_hierarchy_raw $val |
|
} |
|
QKEY { |
|
lappend key_hierarchy [::tomlish::utils::unescape_string $val] |
|
lappend key_hierarchy_raw \"$val\" |
|
} |
|
SQKEY { |
|
lappend key_hierarchy $val |
|
lappend key_hierarchy_raw "'$val'" |
|
} |
|
default { |
|
error "DOTTED key unexpected part '$parttag' - ensure dot separator is between key parts. '$item'" |
|
} |
|
} |
|
set expect_sep 1 |
|
} |
|
} |
|
return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] |
|
} |
|
|
|
|
|
|
|
#to_dict is a *basic* programmatic datastructure for accessing the data. |
|
# produce a dictionary of keys and values from a tomlish tagged list. |
|
# to_dict is primarily for reading toml data. |
|
#Extraneous (not within quoted sections) whitespace and comments are not preserved in this structure, |
|
# so a roundtrip from toml to this datastructure and back to toml will lose whitespace formatting and comments. |
|
# creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. |
|
#A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. |
|
# |
|
#Note, currently we get a plain sub dictionary when an inline table is a direct value for a key, but an ITABLE when it's in an ARRAY - REVIEW |
|
#Namespacing? |
|
#ie note the difference: |
|
#[Data] |
|
#temp = { cpu = 79.5, case = 72.0} |
|
# versus |
|
#[Data] |
|
#temps = [{cpu = 79.5, case = 72.0}] |
|
proc to_dict {tomlish} { |
|
|
|
#keep track of which tablenames have already been directly defined, |
|
# so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' |
|
#Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. |
|
#we don't error out just because a previous tablename segment has already appeared. |
|
##variable tablenames_seen [list] |
|
if {[uplevel 1 [list info exists tablenames_seen]]} { |
|
upvar tablenames_seen tablenames_seen |
|
} else { |
|
set tablenames_seen [list] |
|
} |
|
|
|
log::info ">>> processing '$tomlish'<<<" |
|
set items $tomlish |
|
|
|
foreach lst $items { |
|
if {[lindex $lst 0] ni $::tomlish::tags} { |
|
error "supplied string does not appear to be toml parsed into a tomlish tagged list. Run tomlish::decode::toml on the raw toml data to produce a tomlish list" |
|
} |
|
} |
|
|
|
if {[lindex $tomlish 0] eq "TOMLISH"} { |
|
#ignore TOMLISH tag at beginning |
|
set items [lrange $tomlish 1 end] |
|
} |
|
|
|
set datastructure [dict create] |
|
foreach item $items { |
|
set tag [lindex $item 0] |
|
#puts "...> item:'$item' tag:'$tag'" |
|
switch -exact -- $tag { |
|
KEY - QKEY - SQKEY { |
|
log::debug "--> processing $tag: $item" |
|
set key [lindex $item 1] |
|
if {$tag eq "QKEY"} { |
|
set key [::tomlish::utils::unescape_string $key] |
|
} |
|
#!todo - normalize key. (may be quoted/doublequoted) |
|
|
|
if {[dict exists $datastructure $key]} { |
|
error "Duplicate key '$key'. The key already exists at this level in the toml data. The toml data is not valid." |
|
} |
|
|
|
#lassign [_get_keyval_value $item] type val |
|
set keyval_dict [_get_keyval_value $item] |
|
dict set datastructure $key $keyval_dict |
|
} |
|
DOTTEDKEY { |
|
log::debug "--> processing $tag: $item" |
|
set dkey_info [_get_dottedkey_info $item] |
|
set dotted_key_hierarchy [dict get $dkey_info keys] |
|
set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] |
|
|
|
#a.b.c = 1 |
|
#table_key_hierarchy -> a b |
|
#leafkey -> c |
|
if {[llength $dotted_key_hierarchy] == 0} { |
|
#empty?? probably invalid. review |
|
#This is different to '' = 1 or ''.'' = 1 which have lengths 1 and 2 respectively |
|
error "DOTTED key has no parts - invalid? '$item'" |
|
} elseif {[llength $dotted_key_hierarchy] == 1} { |
|
#dottedkey is only a key - no table component |
|
set table_hierarchy [list] |
|
set leafkey [lindex $dotted_key_hierarchy 0] |
|
} else { |
|
set table_hierarchy [lrange $dotted_key_hierarchy 0 end-1] |
|
set table_hierarchy_raw [lrange $dotted_key_hierarchy_raw 0 end-1] |
|
set leafkey [lindex $dotted_key_hierarchy end] |
|
} |
|
|
|
#ensure empty tables are still represented in the datastructure |
|
set pathkeys [list] |
|
foreach k $table_hierarchy { |
|
lappend pathkeys $k |
|
if {![dict exists $datastructure {*}$pathkeys]} { |
|
dict set datastructure {*}$pathkeys [list] |
|
} else { |
|
tomlish::log::notice "to_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" |
|
} |
|
} |
|
|
|
set keyval_dict [_get_keyval_value $item] |
|
dict set datastructure {*}$pathkeys $leafkey $keyval_dict |
|
|
|
#JMN test 2025 |
|
|
|
} |
|
TABLE { |
|
set tablename [lindex $item 1] |
|
set tablename [::tomlish::utils::tablename_trim $tablename] |
|
|
|
if {$tablename in $tablenames_seen} { |
|
error "Table name '$tablename' has already been directly defined in the toml data. Invalid." |
|
} |
|
|
|
log::debug "--> processing $tag (name: $tablename): $item" |
|
set name_segments [::tomlish::utils::tablename_split $tablename] |
|
set last_seg "" |
|
#toml spec rule - all segments mst be non-empty |
|
#note that the results of tablename_split are 'raw' - ie some segments may be enclosed in single or double quotes. |
|
|
|
set table_key_hierarchy [list] |
|
set table_key_hierarchy_raw [list] |
|
|
|
foreach rawseg $name_segments { |
|
|
|
set seg [::tomlish::utils::normalize_key $rawseg] ;#strips one level of enclosing quotes, and substitutes only toml-specified escapes |
|
set c1 [tcl::string::index $rawseg 0] |
|
set c2 [tcl::string::index $rawseg end] |
|
if {($c1 eq "'") && ($c2 eq "'")} { |
|
#single quoted segment. No escapes are processed within it. |
|
set seg [tcl::string::range $rawseg 1 end-1] |
|
} elseif {($c1 eq "\"") && ($c2 eq "\"")} { |
|
#double quoted segment. Apply escapes. |
|
set seg [::tomlish::utils::unescape_string [tcl::string::range $rawseg 1 end-1]] |
|
} else { |
|
set seg $rawseg |
|
} |
|
|
|
#no need to check for empty segments here - we've already called tablename_split which would have raised an error for empty segments. |
|
#if {$rawseg eq ""} { |
|
# error "Table name '[lindex $item 1]' is not valid. All segments (parts between dots) must be non-empty" |
|
#} |
|
lappend table_key_hierarchy $seg |
|
lappend table_key_hierarchy_raw $rawseg |
|
|
|
if {[dict exists $datastructure {*}$table_key_hierarchy]} { |
|
#It's ok for this key to already exist *if* it was defined by a previous tablename or equivalent |
|
#and if this key is longer |
|
|
|
#consider the following 2 which are legal: |
|
#[table] |
|
#x.y = 3 |
|
#[table.x.z] |
|
#k= 22 |
|
|
|
#equivalent |
|
|
|
#[table] |
|
#[table.x] |
|
#y = 3 |
|
#[table.x.z] |
|
#k=22 |
|
|
|
#illegal |
|
#[table] |
|
#x.y = 3 |
|
#[table.x.y.z] |
|
#k = 22 |
|
## - we should bfail on encoungerint table.x.y because only table and table.x are effectively tables |
|
## - we should also fail if |
|
|
|
#illegal |
|
#[table] |
|
#x.y = {p=3} |
|
#[table.x.y.z] |
|
#k = 22 |
|
## we should fail because y is an inline table which is closed to further entries |
|
|
|
|
|
#TODO! fix - this code is wrong |
|
|
|
set testkey [join $table_key_hierarchy_raw .] |
|
|
|
set testkey_length [llength $table_key_hierarchy_raw] |
|
set found_testkey 0 |
|
if {$testkey in $tablenames_seen} { |
|
set found_testkey 1 |
|
} else { |
|
#see if it was defined by a longer entry |
|
foreach seen $tablenames_seen { |
|
set seen_segments [::tomlish::utils::tablename_split $seen] |
|
#these are raw unnormalized tablename segments. Need to normalize the double-quoted ones, |
|
# and strip the quotes from both single-quoted and double-quoted entries. |
|
|
|
#note: it is not safe to compare normalized tablenames using join! |
|
# e.g a.'b.c'.d is not the same as a.b.c.d |
|
# instead compare {a b.c d} with {a b c d} |
|
# Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. |
|
#'a.b'.'c.d.e' vs 'a.b.c'.'d.e' |
|
|
|
#VVV the test below is wrong VVV! |
|
#we need to normalize the tablenames seen so that {"x\ty"} matches {"x<rawtab>y"} |
|
|
|
set seen_match [join [lrange $seen_segments 0 [expr {$testkey_length -1}]] .] |
|
puts stderr "testkey:'$testkey' vs seen_match:'$seen_match'" |
|
if {$testkey eq $seen_match} { |
|
set found_testkey 1 |
|
} |
|
} |
|
} |
|
|
|
if {$found_testkey == 0} { |
|
#the raw table_key_hierarchy is better to display in the error message, although it's not the actual dict keyset |
|
set msg "key [join $table_key_hierarchy_raw .] already exists in datastructure, but wasn't defined by a supertable." |
|
append msg \n "tablenames_seen:" \n |
|
foreach ts $tablenames_seen { |
|
append msg " " $ts \n |
|
} |
|
error $msg |
|
} |
|
} |
|
|
|
} |
|
|
|
#ensure empty tables are still represented in the datastructure |
|
set table_keys [list] |
|
foreach k $table_key_hierarchy { |
|
lappend table_keys $k |
|
if {![dict exists $datastructure {*}$table_keys]} { |
|
dict set datastructure {*}$table_keys [list] |
|
} else { |
|
tomlish::log::notice "to_dict datastructure at (TABLE) subkey $table_keys already had data: [dict get $datastructure {*}$table_keys]" |
|
} |
|
} |
|
|
|
#We must do this after the key-collision test above! |
|
lappend tablenames_seen $tablename |
|
|
|
|
|
log::debug ">>>>>>>>>>>>>>>>>>>>table_key_hierarchy : $table_key_hierarchy" |
|
log::debug ">>>>>>>>>>>>>>>>>>>>table_key_hierarchy_raw: $table_key_hierarchy_raw" |
|
|
|
#now add the contained elements |
|
foreach element [lrange $item 2 end] { |
|
set type [lindex $element 0] |
|
log::debug "--> $type processing contained element $element" |
|
switch -exact -- $type { |
|
DOTTEDKEY { |
|
set dkey_info [_get_dottedkey_info $element] |
|
#e.g1 keys {x.y y} keys_raw {'x.y' y} |
|
#e.g2 keys {x.y y} keys_raw {{"x.y"} y} |
|
set dotted_key_hierarchy [dict get $dkey_info keys] |
|
set dkeys [lrange $dotted_key_hierarchy 0 end-1] |
|
set leaf_key [lindex $dotted_key_hierarchy end] |
|
set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] |
|
set dkeys_raw [lrange $dotted_key_hierarchy_raw 0 end-1] |
|
set leaf_key_raw [lindex $dotted_key_hierarchy_raw end] |
|
|
|
#ensure empty keys are still represented in the datastructure |
|
set test_keys $table_keys |
|
foreach k $dkeys { |
|
lappend test_keys $k |
|
if {![dict exists $datastructure {*}$test_keys]} { |
|
dict set datastructure {*}$test_keys [list] |
|
} else { |
|
tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" |
|
} |
|
} |
|
|
|
if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { |
|
error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." |
|
} |
|
set keyval_dict [_get_keyval_value $element] |
|
#keyval_dict is either a {type <tomltag> value <whatever>} |
|
#or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level |
|
#punk::dict::is_tomlish_typeval can distinguish |
|
puts stdout ">>> $keyval_dict" |
|
dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict |
|
#JMN 2025 |
|
#tomlish::utils::normalize_key ?? |
|
lappend tablenames_seen [join [list {*}$table_key_hierarchy_raw {*}$dkeys_raw] .] ;#???? |
|
#if the keyval_dict is not a simple type x value y - then it's an inline table ? |
|
#if so - we should add the path to the leaf_key as a seen table too - as it's not allowed to have more entries added. |
|
if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { |
|
#the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys |
|
# inner structure will contain {type <tag> value <etc>} if all leaves are not empty ITABLES |
|
lappend tablenames_seen [join [list {*}$table_key_hierarchy_raw {*}$dkeys_raw $leaf_key_raw] .] |
|
} |
|
|
|
} |
|
KEY - QKEY - SQKEY { |
|
#obsolete ? |
|
set keyval_key [lindex $element 1] |
|
if {$type eq "QKEY"} { |
|
set keyval_key [::tomlish::utils::unescape_string $keyval_key] |
|
} |
|
if {[dict exists $datastructure {*}$dotted_key_hierarchy $keyval_key]} { |
|
error "Duplicate key '$dotted_key_hierarchy $key'. The key already exists at this level in the toml data. The toml data is not valid." |
|
} |
|
set keyval_dict [_get_keyval_value $element] |
|
dict set datastructure {*}$dotted_key_hierarchy $keyval_key $keyval_dict |
|
} |
|
NEWLINE - COMMENT - WS { |
|
#ignore |
|
} |
|
default { |
|
error "Sub element of type '$type' not understood in table context. Expected only KEY,QKEY,SQKEY,NEWLINE,COMMENT,WS" |
|
} |
|
} |
|
} |
|
#now make sure we add an empty value if there were no contained elements! |
|
#!todo. |
|
} |
|
ITABLE { |
|
#SEP??? |
|
set datastructure [list] |
|
foreach element [lrange $item 1 end] { |
|
set type [lindex $element 0] |
|
switch -exact -- $type { |
|
DOTTEDKEY { |
|
set dkey_info [_get_dottedkey_info $element] |
|
set dotted_key_hierarchy [dict get $dkey_info keys] |
|
set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw] |
|
set leaf_key [lindex $dotted_key_hierarchy end] |
|
set dkeys [lrange $dotted_key_hierarchy 0 end-1] |
|
|
|
#ensure empty keys are still represented in the datastructure |
|
set table_keys [list] ;#We don't know the context - next level up will have to check for key collisions? |
|
set test_keys $table_keys |
|
foreach k $dkeys { |
|
lappend test_keys $k |
|
if {![dict exists $datastructure {*}$test_keys]} { |
|
dict set datastructure {*}$test_keys [list] |
|
} else { |
|
tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" |
|
} |
|
} |
|
|
|
if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { |
|
error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." |
|
} |
|
set keyval_dict [_get_keyval_value $element] |
|
dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict |
|
} |
|
NEWLINE - COMMENT - WS { |
|
#ignore |
|
} |
|
default { |
|
error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,QKEY,SQKEY,NEWLINE,COMMENT,WS" |
|
} |
|
} |
|
} |
|
} |
|
ARRAY { |
|
#arrays in toml are allowed to contain mixtures of types |
|
set datastructure [list] |
|
log::debug "--> processing array: $item" |
|
|
|
foreach element [lrange $item 1 end] { |
|
set type [lindex $element 0] |
|
switch -exact -- $type { |
|
INT - FLOAT - BOOL - DATETIME { |
|
set value [lindex $element 1] |
|
lappend datastructure [list type $type value $value] |
|
} |
|
STRING { |
|
set value [lindex $element 1] |
|
lappend datastructure [list type $type value [::tomlish::utils::unescape_string $value]] |
|
} |
|
LITERAL { |
|
set value [lindex $element 1] |
|
lappend datastructure [list type $type value $value] |
|
} |
|
ITABLE - TABLE - ARRAY - MULTISTRING - MULTILITERAL { |
|
set value [lindex $element 1] |
|
lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] |
|
} |
|
WS - SEP - NEWLINE - COMMENT { |
|
#ignore whitespace, commas, newlines and comments |
|
} |
|
default { |
|
error "Unexpected value type '$type' found in array" |
|
} |
|
} |
|
} |
|
} |
|
MULTILITERAL { |
|
#triple squoted string |
|
#first newline stripped only if it is the very first element |
|
#(ie *immediately* following the opening delims) |
|
#All whitespace other than newlines is within LITERALPARTS |
|
# ------------------------------------------------------------------------- |
|
#todo - consider extension to toml to allow indent-aware multiline literals |
|
# how - propose as issue in toml github? Use different delim? e.g ^^^ ? |
|
#e.g |
|
# xxx=?'''abc |
|
# def |
|
# etc |
|
# ''' |
|
# - we would like to trimleft each line to the column following the opening delim |
|
# ------------------------------------------------------------------------- |
|
|
|
log::debug "--> processing multiliteral: $item" |
|
set parts [lrange $item 1 end] |
|
if {[lindex $parts 0 0] eq "NEWLINE"} { |
|
set parts [lrange $parts 1 end] ;#skip it |
|
} |
|
for {set idx 0} {$idx < [llength $parts]} {incr idx} { |
|
set element [lindex $parts $idx] |
|
set type [lindex $element 0] |
|
switch -exact -- $type { |
|
LITERALPART { |
|
append stringvalue [lindex $element 1] |
|
} |
|
NEWLINE { |
|
set val [lindex $element 1] |
|
if {$val eq "nl"} { |
|
append stringvalue \n |
|
} else { |
|
append stringvalue \r\n |
|
} |
|
} |
|
default { |
|
error "Unexpected value type '$type' found in multistring" |
|
} |
|
} |
|
} |
|
set datastructure $stringvalue |
|
} |
|
MULTISTRING { |
|
#triple dquoted string |
|
log::debug "--> processing multistring: $item" |
|
set stringvalue "" |
|
set idx 0 |
|
set parts [lrange $item 1 end] |
|
for {set idx 0} {$idx < [llength $parts]} {incr idx} { |
|
set element [lindex $parts $idx] |
|
set type [lindex $element 0] |
|
#We use STRINGPART in the tomlish representation as a distinct element to STRING - which would imply wrapping quotes to be reinserted |
|
switch -exact -- $type { |
|
STRING { |
|
#todo - do away with STRING ? |
|
#we don't build MULTISTRINGS containing STRING - but should we accept it? |
|
tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" |
|
append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" |
|
} |
|
STRINGPART { |
|
append stringvalue [::tomlish::utils::unescape_string [lindex $element 1]] |
|
} |
|
CONT { |
|
#When the last non-whitespace character on a line is an unescaped backslash, |
|
#it will be trimmed along with all whitespace (including newlines) up to the next non-whitespace character or closing delimiter |
|
# review - we allow some whitespace in stringpart elements - can a stringpart ever be all whitespace? |
|
set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] |
|
if {$next_nl == -1} { |
|
#last line |
|
set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] |
|
if {$non_ws >= 0} { |
|
append stringvalue "\\" ;#add the sep |
|
} else { |
|
#skip over ws without emitting |
|
set idx [llength $parts] |
|
} |
|
} else { |
|
set parts_til_nl [lrange $parts 0 $next_nl-1] |
|
set non_ws [lsearch -index 0 -start $idx+1 -not $parts_til_nl WS] |
|
if {$non_ws >= 0} { |
|
append stringvalue "\\" |
|
} else { |
|
#skip over ws on this line |
|
set idx $next_nl |
|
#then have to check each subsequent line until we get to first non-whitespace |
|
set trimming 1 |
|
while {$trimming && $idx < [llength $parts]} { |
|
set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] |
|
if {$next_nl == -1} { |
|
#last line |
|
set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] |
|
if {$non_ws >= 0} { |
|
set idx [expr {$non_ws -1}] |
|
} else { |
|
set idx [llength $parts] |
|
} |
|
set trimming 0 |
|
} else { |
|
set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] |
|
if {$non_ws >= 0} { |
|
set idx [expr {$non_ws -1}] |
|
set trimming 0 |
|
} else { |
|
set idx $next_nl |
|
#keep trimming |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
NEWLINE { |
|
#if newline is first element - it is not part of the data of a multistring |
|
if {$idx > 0} { |
|
set val [lindex $element 1] |
|
if {$val eq "nl"} { |
|
append stringvalue \n |
|
} else { |
|
append stringvalue \r\n |
|
} |
|
} |
|
} |
|
WS { |
|
append stringvalue [lindex $element 1] |
|
} |
|
default { |
|
error "Unexpected value type '$type' found in multistring" |
|
} |
|
} |
|
} |
|
set datastructure $stringvalue |
|
} |
|
WS - COMMENT - NEWLINE { |
|
#ignore |
|
} |
|
default { |
|
error "Unexpected tag '$tag' in Tomlish list '$tomlish'" |
|
} |
|
} |
|
} |
|
return $datastructure |
|
} |
|
|
|
|
|
proc _from_dictval_tomltype {parents tablestack keys typeval} { |
|
set type [dict get $typeval type] |
|
set val [dict get $typeval value] |
|
switch -- $type { |
|
ARRAY { |
|
set subitems [list] |
|
foreach item $val { |
|
lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP |
|
} |
|
if {[lindex $subitems end] eq "SEP"} { |
|
set subitems [lrange $subitems 0 end-1] |
|
} |
|
return [list ARRAY {*}$subitems] |
|
} |
|
ITABLE { |
|
if {$val eq ""} { |
|
return ITABLE |
|
} else { |
|
return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] |
|
} |
|
} |
|
MULTISTRING { |
|
#value is a raw string that isn't encoded as tomlish |
|
#create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format |
|
set tomlpart "x=\"\"\"\\\n" |
|
append tomlpart $val "\"\"\"" |
|
set tomlish [tomlish::decode::toml $tomlpart] |
|
#e.g if val = " etc\nblah" |
|
#TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } |
|
#lindex 1 3 is the MULTISTRING tomlish list |
|
return [lindex $tomlish 1 3] |
|
} |
|
MULTILITERAL { |
|
set tomlpart "x='''\n" |
|
append tomlpart $val ''' |
|
set tomlish [tomlish::decode::toml $tomlpart] |
|
return [lindex $tomlish 1 3] |
|
} |
|
default { |
|
return [list $type $val] |
|
} |
|
} |
|
} |
|
|
|
proc _from_dictval {parents tablestack keys vinfo} { |
|
set k [lindex $keys end] |
|
if {[regexp {\s} $k] || [string first . $k] >= 0} { |
|
#Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! |
|
#todo - QKEY? |
|
set K_PART [list SQKEY $k] |
|
} else { |
|
set K_PART [list KEY $k] |
|
} |
|
puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" |
|
puts stderr "---tablestack: $tablestack---" |
|
set result [list] |
|
set lastparent [lindex $parents end] |
|
if {$lastparent in [list "" do_inline]} { |
|
if {[tomlish::dict::is_tomlish_typeval $vinfo]} { |
|
set type [dict get $vinfo type] |
|
#treat ITABLE differently? |
|
set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] |
|
lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} |
|
} else { |
|
#set result [list TABLE $k {NEWLINE lf}] |
|
if {$vinfo ne ""} { |
|
|
|
#set result [list DOTTEDKEY [list [list KEY $k]] = ] |
|
#set records [list ITABLE] |
|
|
|
set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] |
|
|
|
if {$lastparent eq "do_inline"} { |
|
set result [list DOTTEDKEY [list $K_PART] =] |
|
set records [list ITABLE] |
|
} else { |
|
#review - quoted k ?? |
|
set result [list TABLE $k {NEWLINE lf}] |
|
set tablestack [list {*}$tablestack [list T $k]] |
|
set records [list] |
|
} |
|
|
|
|
|
|
|
set lastidx [expr {[dict size $vinfo] -1}] |
|
set dictidx 0 |
|
dict for {vk vv} $vinfo { |
|
if {[regexp {\s} $vk] || [string first . $vk] >= 0} { |
|
set VK_PART [list SQKEY $vk] |
|
} else { |
|
set VK_PART [list KEY $vk] |
|
} |
|
if {[tomlish::dict::is_tomlish_typeval $vv]} { |
|
#type x value y |
|
set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] |
|
set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] |
|
} else { |
|
if {$vv eq ""} { |
|
#experimental |
|
if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { |
|
puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" |
|
#set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] |
|
set tname [join [list {*}$keys $vk] .] |
|
set record [list TABLE $tname {NEWLINE lf}] |
|
set tablestack [list {*}$tablestack [list T $vk]] |
|
} else { |
|
set record [list DOTTEDKEY [list $VK_PART] = ITABLE] |
|
set tablestack [list {*}$tablestack [list I $vk]] |
|
} |
|
} else { |
|
if { 0 } { |
|
#experiment.. sort of getting there. |
|
if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { |
|
puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" |
|
set tname [join [list {*}$keys $vk] .] |
|
set record [list TABLE $tname {NEWLINE lf}] |
|
set tablestack [list {*}$tablestack [list T $vk]] |
|
|
|
#review - todo? |
|
set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] |
|
lappend record {*}$dottedkey_value |
|
|
|
} else { |
|
set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] |
|
set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] |
|
} |
|
} else { |
|
set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] |
|
set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] |
|
} |
|
} |
|
} |
|
if {$dictidx != $lastidx} { |
|
#lappend record SEP |
|
if {$lastparent eq "do_inline"} { |
|
lappend record SEP |
|
} else { |
|
lappend record {NEWLINE lf} |
|
} |
|
} |
|
lappend records $record |
|
incr dictidx |
|
} |
|
if {$lastparent eq "do_inline"} { |
|
lappend result $records {NEWLINE lf} |
|
} else { |
|
lappend result {*}$records {NEWLINE lf} |
|
} |
|
} else { |
|
if {$lastparent eq "do_inline"} { |
|
lappend result DOTTEDKEY [list [list KEY $k]] = ITABLE {NEWLINE lf} |
|
} else { |
|
lappend result TABLE $k {NEWLINE lf} |
|
} |
|
} |
|
} |
|
} else { |
|
#lastparent is not toplevel "" or "do_inline" |
|
if {[tomlish::dict::is_tomlish_typeval $vinfo]} { |
|
#type x value y |
|
set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] |
|
lappend result {*}$sublist |
|
} else { |
|
if {$lastparent eq "TABLE"} { |
|
#review |
|
dict for {vk vv} $vinfo { |
|
set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] |
|
lappend result [list DOTTEDKEY [list [list KEY $vk]] = $dottedkey_value {NEWLINE lf}] |
|
} |
|
} else { |
|
if {$vinfo ne ""} { |
|
set lastidx [expr {[dict size $vinfo] -1}] |
|
set dictidx 0 |
|
set sub [list] |
|
set result $lastparent ;#e.g sets ITABLE |
|
set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] |
|
dict for {vk vv} $vinfo { |
|
if {[regexp {\s} $vk] || [string first . $vk] >=0} { |
|
set VK_PART [list SQKEY $vk] |
|
} else { |
|
set VK_PART [list KEY $vk] |
|
} |
|
if {[tomlish::dict::is_tomlish_typeval $vv]} { |
|
#type x value y |
|
set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] |
|
set record [list DOTTEDKEY [list $VK_PART] = $sublist] |
|
} else { |
|
if {$vv eq ""} { |
|
#can't just uninline at this level |
|
#we need a better method to query main dict for uninlinability at each level |
|
# (including what's been inlined already) |
|
#if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { |
|
# puts stderr "_from_dictval uninline2 KEY $keys" |
|
# set tname [join [list {*}$keys $vk] .] |
|
# set record [list TABLE $tname {NEWLINE lf}] |
|
# set tablestack [list {*}$tablestack [list T $vk]] |
|
#} else { |
|
set record [list DOTTEDKEY [list $VK_PART] = ITABLE] |
|
#} |
|
} else { |
|
#set sub [_from_dictval ITABLE $vk $vv] |
|
set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] |
|
#set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] |
|
set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] |
|
} |
|
} |
|
if {$dictidx != $lastidx} { |
|
lappend record SEP |
|
} |
|
lappend result $record |
|
incr dictidx |
|
} |
|
} else { |
|
puts stderr "table x-1" |
|
lappend result DOTTEDKEY [list $K_PART] = ITABLE |
|
} |
|
} |
|
} |
|
} |
|
return $result |
|
} |
|
|
|
|
|
proc from_dict {d} { |
|
#consider: |
|
# t1={a=1,b=2} |
|
# x = 1 |
|
#If we represent t1 as an expanded table we get |
|
# [t1] |
|
# a=1 |
|
# b=2 |
|
# x=1 |
|
# --- which is incorrect - as x was a toplevel key like t1! |
|
#This issue doesn't occur if x is itself an inline table |
|
# t1={a=1,b=2} |
|
# x= {no="problem"} |
|
# |
|
# (or if we were to reorder x to come before t1) |
|
|
|
#As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} |
|
#Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, |
|
#which is unpreferred here. |
|
|
|
#A possible solution: |
|
#scan the top level to see if all (trailing) elements are themselves dicts |
|
# (ie not of form {type XXX value yyy}) |
|
# |
|
# A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements |
|
#ie we don't need to force do_inline if all the 'simple' keys are before any compound keys |
|
|
|
#set root_has_values 0 |
|
#approach 1) - the naive approach - forces inline when not always necessary |
|
#dict for {k v} $d { |
|
# if {[llength $v] == 4 && [lindex $v 0] eq "type"} { |
|
# set root_has_values 1 |
|
# break |
|
# } |
|
#} |
|
|
|
|
|
#approach 2) - track the position of last {type x value y} in the dictionary built by to_dict |
|
# - still not perfect. Inlines dotted tables unnecessarily |
|
#This means from_dict doesn't produce output optimal for human editing. |
|
set last_simple [tomlish::dict::last_tomltype_posn $d] |
|
|
|
|
|
## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values |
|
#Any keys that are themselves tables - will need to be represented inline |
|
#to avoid reordering, or incorrect assignment of plain values to the wrong table. |
|
|
|
## set parent "" |
|
#all toplevel keys in the dict structure can represent subtables. |
|
#we are free to use {[tablename]\n} syntax for toplevel elements. |
|
|
|
|
|
set tomlish [list TOMLISH] |
|
set dictposn 0 |
|
set tablestack [list [list T root]] ;#todo |
|
dict for {t tinfo} $d { |
|
if {$last_simple > $dictposn} { |
|
set parents [list do_inline] |
|
} else { |
|
set parents [list ""] |
|
} |
|
set keys [list $t] |
|
set trecord [_from_dictval $parents $tablestack $keys $tinfo] |
|
lappend tomlish $trecord |
|
incr dictposn |
|
} |
|
return $tomlish |
|
} |
|
|
|
proc json_to_toml {json} { |
|
#*** !doctools |
|
#[call [fun json_to_toml] [arg json]] |
|
#[para] |
|
|
|
set tomlish [::tomlish::from_json $json] |
|
set toml [::tomlish::to_toml $tomlish] |
|
} |
|
|
|
#TODO use huddle? |
|
proc from_json {json} { |
|
set jstruct [::tomlish::json_struct $json] |
|
return [::tomlish::from_json_struct $jstruct] |
|
} |
|
|
|
proc from_json_struct {jstruct} { |
|
package require fish::json_toml |
|
return [fish::json_toml::jsonstruct2tomlish $jstruct] |
|
} |
|
|
|
proc toml_to_json {toml} { |
|
set tomlish [::tomlish::from_toml $toml] |
|
return [::tomlish::get_json $tomlish] |
|
} |
|
|
|
proc get_json {tomlish} { |
|
package require fish::json |
|
set d [::tomlish::to_dict $tomlish] |
|
#return [::tomlish::dict_to_json $d] |
|
return [fish::json::from "struct" $d] |
|
} |
|
|
|
|
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace tomlish ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
namespace eval tomlish::encode { |
|
#*** !doctools |
|
#[subsection {Namespace tomlish::encode}] |
|
#[para] |
|
#[list_begin definitions] |
|
|
|
#STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness |
|
# take a value of the appropriate type and wrap as a tomlish tagged item |
|
proc string {s} { |
|
return [list STRING $s] |
|
} |
|
|
|
proc int {i} { |
|
#whole numbers, may be prefixed with a + or - |
|
#Leading zeros are not allowed |
|
#Hex,octal binary forms are allowed (toml 1.0) |
|
#We will error out on encountering commas, as commas are interpreted differently depending on locale (and don't seem to be supported in the toml spec anyway) |
|
#!todo - Tcl can handle bignums - bigger than a 64bit signed long as specified in toml. |
|
# - We should probably raise an error for number larger than this and suggest the user supply it as a string? |
|
if {[tcl::string::last , $i] > -1} { |
|
error "Unable to interpret '$i' as an integer. Use underscores if you need a thousands separator [::tomlish::parse::report_line]" |
|
} |
|
if {![::tomlish::utils::int_validchars $i]} { |
|
error "Unable to interpret '$i' as an integer. Only 0-9 + 1 _ characters are acceptable. [::tomlish::parse::report_line]" |
|
} |
|
|
|
if {[::tomlish::utils::is_int $i]} { |
|
return [list INT $i] |
|
} else { |
|
error "'$i' is not a valid integer as per the Toml spec. [::tomlish::parse::report_line]" |
|
} |
|
|
|
} |
|
|
|
proc float {f} { |
|
#convert any non-lower case variants of special values to lowercase for Toml |
|
if {[::tcl::string::tolower $f] in {nan +nan -nan inf +inf -inf}} { |
|
return [list FLOAT [tcl::string::tolower $f]] |
|
} |
|
if {[::tomlish::utils::is_float $f]} { |
|
return [list FLOAT $f] |
|
} else { |
|
error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" |
|
} |
|
} |
|
|
|
proc datetime {str} { |
|
if {[::tomlish::utils::is_datetime $str]} { |
|
return [list DATETIME $str] |
|
} else { |
|
error "Unable to interpret '$str' as Toml datetime. Check your input, or check that tomlish is able to handle all Toml datetimes properly [::tomlish::parse::report_line]" |
|
} |
|
} |
|
|
|
proc boolean {b} { |
|
#convert any Tcl-acceptable boolean to boolean as accepted by toml - lower case true/false |
|
if {![tcl::string::is boolean -strict $b]} { |
|
error "Unable to convert '$b' to Toml boolean true|false. [::tomlish::parse::report_line]" |
|
} else { |
|
if {[expr {$b && 1}]} { |
|
return [::list BOOL true] |
|
} else { |
|
return [::list BOOL false] |
|
} |
|
} |
|
} |
|
|
|
|
|
#TODO |
|
#Take tablename followed by |
|
# a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} |
|
# (accept also key <keyname> value {STRING <value>}) |
|
# b) simple 2-element tcl lists being name & *simple* value pairs for which basic heuristics will be used to determine types |
|
proc table {name args} { |
|
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 <keyname> = <value> 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 <name> = {<type> <val}' or simple name-value pairs expected. Unable to handle [llength $t] element list as argument" |
|
} |
|
} |
|
set result [list TABLE $name {NEWLINE lf}] |
|
foreach p $pairs { |
|
lappend result $p {NEWLINE lf} |
|
} |
|
return $result |
|
#return [list TABLE $name $pairs] |
|
} |
|
|
|
|
|
#the tomlish root is basically a nameless table representing the root of the document |
|
proc root {args} { |
|
set table [::tomlish::encode::table TOMLISH {*}$args] |
|
set result [lrange $table 2 end] |
|
} |
|
|
|
#WS = whitepace, US = underscore |
|
proc tomlish {list {context ""}} { |
|
if {![tcl::string::is list $list]} { |
|
error "Supplied 'tomlish' is not a valid Tcl list. Expected a tagged list (parsed Toml)" |
|
} |
|
set toml "" ;#result string |
|
|
|
foreach item $list { |
|
set tag [lindex $item 0] |
|
#puts "tomlish::encode::tomlish processing item '$item', tag '$tag'" |
|
#during recursion, some tags require different error checking in different contexts. |
|
set nextcontext $tag ; |
|
|
|
|
|
#Handle invalid tag nestings |
|
switch -- $context { |
|
QKEY - |
|
SQKEY - |
|
KEY { |
|
if {$tag in {KEY QKEY SQKEY}} { |
|
error "Invalid tag '$tag' encountered within '$context'" |
|
} |
|
} |
|
MULTISTRING { |
|
#explicitly list the valid child tags |
|
set ms_parts {STRING STRINGPART WS NEWLINE CONT} |
|
if {$tag ni $ms_parts} { |
|
error "Invalid tag '$tag' encountered within a MULTISTRING must belong to: $ms_parts" |
|
} |
|
} |
|
MULTILITERAL { |
|
set ml_parts {LITERALPART NEWLINE} |
|
if {$tag ni $ml_parts} { |
|
error "Invalid tag '$tag' encountered within a MULTILITERAL must belong to: $ml_parts" |
|
} |
|
} |
|
default { |
|
#no context, or no defined nesting error for this context |
|
} |
|
} |
|
|
|
switch -- $tag { |
|
TOMLISH { |
|
#optional root tag. Ignore. |
|
} |
|
QKEY - |
|
SQKEY - |
|
KEY { |
|
# |
|
if {$tag eq "KEY"} { |
|
append toml [lindex $item 1] ;#Key |
|
} elseif {$tag eq "SQKEY"} { |
|
append toml '[lindex $item 1]' ;#SQuoted Key |
|
} else { |
|
append toml \"[lindex $item 1]\" ;#Quoted Key |
|
} |
|
#= could be at various positions depending on WS |
|
foreach part [lrange $item 2 end] { |
|
if {$part eq "="} { |
|
append toml "=" |
|
} else { |
|
append toml [::tomlish::encode::tomlish [list $part] $nextcontext] |
|
} |
|
} |
|
} |
|
DOTTEDKEY { |
|
#QKEY, SQKEY, BAREKEY, WS, DOTSEP |
|
foreach part [lindex $item 1] { |
|
append toml [::tomlish::encode::tomlish [list $part] $nextcontext] |
|
} |
|
#whitespace at tail of dotted key elements is within the list in element 1 |
|
#generally we expect the = to be at element 2 - review |
|
foreach part [lrange $item 2 end] { |
|
if {$part eq "="} { |
|
append toml "=" |
|
} else { |
|
#puts "encoding [list $part] (context:$nextcontext)" |
|
append toml [::tomlish::encode::tomlish [list $part] $nextcontext] |
|
} |
|
} |
|
} |
|
TABLE { |
|
append toml "\[[lindex $item 1]\]" ;#table name |
|
foreach part [lrange $item 2 end] { |
|
append toml [::tomlish::encode::tomlish [list $part] $nextcontext] |
|
} |
|
|
|
} |
|
ITABLE { |
|
#inline table - e.g within array or on RHS of keyval/qkeyval |
|
set data "" |
|
foreach part [lrange $item 1 end] { |
|
append data [::tomlish::encode::tomlish [list $part] $nextcontext] |
|
} |
|
append toml "\{$data\}" |
|
} |
|
ARRAY { |
|
|
|
set arraystr "" |
|
foreach part [lrange $item 1 end] { |
|
append arraystr [::tomlish::encode::tomlish [list $part] $nextcontext] |
|
} |
|
append toml "\[$arraystr\]" |
|
} |
|
WS { |
|
append toml [lindex $item 1] |
|
} |
|
SEP { |
|
append toml "," |
|
} |
|
DOTSEP { |
|
append toml "." |
|
} |
|
NEWLINE { |
|
set chartype [lindex $item 1] |
|
if {$chartype eq "lf"} { |
|
append toml \n |
|
} elseif {$chartype eq "crlf"} { |
|
append toml \r\n |
|
} else { |
|
error "Unrecognized newline type '$chartype'" |
|
} |
|
} |
|
CONT { |
|
#line continuation character "\" |
|
append toml "\\" |
|
} |
|
STRING { |
|
#simple double quoted strings only |
|
# |
|
append toml \"[lindex $item 1]\" |
|
} |
|
STRINGPART { |
|
append toml [lindex $item 1] |
|
} |
|
MULTISTRING { |
|
#Tripple quoted string which is a container for newlines,whitespace and multiple strings/stringparts |
|
set multistring "" ;#variable to build up the string |
|
foreach part [lrange $item 1 end] { |
|
append multistring [::tomlish::encode::tomlish [list $part] $nextcontext] |
|
} |
|
append toml "\"\"\"$multistring\"\"\"" |
|
} |
|
LITERAL { |
|
#Single Quoted string(literal string) |
|
append toml '[lindex $item 1]' |
|
} |
|
LITERALPART { |
|
append toml [lindex $item 1] |
|
} |
|
MULTILITERAL { |
|
#multiliteral could be handled as a single literal if we allowed literal to contain newlines |
|
#- except that the first newline must be retained for roundtripping tomlish <-> toml but |
|
# the first newline is not part of the data. |
|
# we elect instead to maintain a basic LITERALPART that must not contain newlines.. |
|
# and to compose MULTILITERAL of multiple NEWLINE LITERALPART parts, |
|
#with the datastructure representation dropping the first newline (if immediately following opening delim) when building the value. |
|
set literal "" |
|
foreach part [lrange $item 1 end] { |
|
append literal [::tomlish::encode::tomlish [list $part] $nextcontext] |
|
} |
|
append toml '''$literal''' |
|
} |
|
INT - |
|
BOOL - |
|
FLOAT - |
|
DATETIME { |
|
append toml [lindex $item 1] |
|
} |
|
INCOMPLETE { |
|
error "cannot process tomlish term tagged as INCOMPLETE" |
|
} |
|
COMMENT { |
|
append toml "#[lindex $item 1]" |
|
} |
|
BOM { |
|
#Byte Order Mark may appear at beginning of a file. Needs to be preserved. |
|
append toml "\uFEFF" |
|
} |
|
default { |
|
error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command." |
|
} |
|
} |
|
|
|
} |
|
return $toml |
|
} |
|
|
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace tomlish::encode ---}] |
|
} |
|
#fish toml from tomlish |
|
|
|
#(encode tomlish as toml) |
|
interp alias {} tomlish::to_toml {} tomlish::encode::tomlish |
|
|
|
# |
|
|
|
|
|
namespace eval tomlish::decode { |
|
#*** !doctools |
|
#[subsection {Namespace tomlish::decode}] |
|
#[para] |
|
#[list_begin definitions] |
|
|
|
#return a Tcl list of tomlish tokens |
|
#i.e get a standard list of all the toml terms in string $s |
|
#where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. |
|
#(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) |
|
# ---------------------------------------------------------------------------------------------- |
|
# NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! |
|
# e.g we deliberately don't check certain things such as duplicate table declarations here. |
|
# ---------------------------------------------------------------------------------------------- |
|
#Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. |
|
# (e.g perhaps a toml editor to highlight violations for fixing) |
|
# A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. |
|
# e.g dicts or an object oriented structure |
|
#Note also - *no* escapes in quoted strings are processed. This is up to the datastructure stage |
|
#e.g to_dict will substitute \r \n \uHHHH \UHHHHHHH etc |
|
#This is important for tomlish to maintain the ability to perform competely lossless round-trips from toml to tomlish and back to toml. |
|
# (which is handy for testing as well as editing some part of the structure with absolutely no effect on other parts of the document) |
|
#If we were to unescape a tab character for example |
|
# - we have no way of knowing if it was originally specified as \t \u0009 or \U00000009 or directly as a tab character. |
|
# For this reason, we also do absolutely no line-ending transformations based on platform. |
|
# All line-endings are maintained as is, and even a file with mixed cr crlf line-endings will be correctly interpreted and can be 'roundtripped' |
|
|
|
proc toml {args} { |
|
#*** !doctools |
|
#[call [fun toml] [arg arg...]] |
|
#[para] return a Tcl list of tomlish tokens |
|
|
|
set s [join $args \n] |
|
|
|
namespace upvar ::tomlish::parse is_parsing is_parsing |
|
set is_parsing 1 |
|
|
|
|
|
if {[info command ::tomlish::parse::spacestack] eq "::tomlish::parse::spacestack"} { |
|
tomlish::parse::spacestack destroy |
|
} |
|
struct::stack ::tomlish::parse::spacestack |
|
|
|
namespace upvar ::tomlish::parse last_space_action last_space_action |
|
namespace upvar ::tomlish::parse last_space_type last_space_type |
|
|
|
|
|
namespace upvar ::tomlish::parse tok tok |
|
set tok "" |
|
|
|
namespace upvar ::tomlish::parse type type |
|
namespace upvar ::tomlish::parse tokenType tokenType |
|
::tomlish::parse::set_tokenType "" |
|
namespace upvar ::tomlish::parse tokenType_list tokenType_list |
|
set tokenType [list] ;#Flat (un-nested) list of tokentypes found |
|
|
|
namespace upvar ::tomlish::parse lastChar lastChar |
|
set lastChar "" |
|
|
|
|
|
set result "" |
|
namespace upvar ::tomlish::parse nest nest |
|
set nest 0 |
|
|
|
namespace upvar ::tomlish::parse v v ;#array keyed on nest level |
|
|
|
|
|
set v(0) {TOMLISH} |
|
array set s0 [list] ;#whitespace data to go in {SPACE {}} element. |
|
set parentlevel 0 |
|
|
|
namespace upvar ::tomlish::parse i i |
|
set i 0 |
|
|
|
namespace upvar ::tomlish::parse state state |
|
|
|
namespace upvar ::tomlish::parse braceCount braceCount |
|
set barceCount 0 |
|
namespace upvar ::tomlish::parse bracketCount bracketCount |
|
set bracketCount 0 |
|
|
|
set sep 0 |
|
set r 1 |
|
namespace upvar ::tomlish::parse token_waiting token_waiting |
|
set token_waiting [dict create] ;#if ::tok finds a *complete* second token during a run, it will put the 2nd one here to be returned by the next call. |
|
|
|
|
|
set state "table-space" |
|
::tomlish::parse::spacestack push {type space state table-space} |
|
namespace upvar ::tomlish::parse linenum linenum;#'line number' of input data. (incremented for each literal linefeed - but not escaped ones in data) |
|
set linenum 1 |
|
|
|
set ::tomlish::parse::state_list [list] |
|
try { |
|
while {$r} { |
|
set r [::tomlish::parse::tok $s] |
|
#puts stdout "got tok: '$tok' while parsing string '$s' " |
|
set next_tokenType_known 0 ;#whether we begin a new token here based on what terminated the token result of 'tok' |
|
|
|
|
|
|
|
#puts "got token: '$tok' tokenType='$tokenType'. while v($nest) = [set v($nest)]" |
|
#puts "-->tok: $tok tokenType='$tokenType'" |
|
set prevstate $state |
|
set transition_info [::tomlish::parse::goNextState $tokenType $tok $state] |
|
#review goNextState could perform more than one space_action |
|
set space_action [dict get $transition_info space_action] |
|
set newstate [dict get $transition_info newstate] ;#use of 'newstate' vs 'state' makes code clearer below |
|
|
|
if {[tcl::string::match "err-*" $state]} { |
|
::tomlish::log::warn "---- State error in state $prevstate for tokenType: $tokenType token value: $tok. $state aborting parse. [tomlish::parse::report_line]" |
|
lappend v(0) [list ERROR tokentype $tokenType state $prevstate to $state leveldata [set v($nest)]] |
|
return $v(0) |
|
} |
|
# --------------------------------------------------------- |
|
#NOTE there may already be a token_waiting at this point |
|
#set_token_waiting can raise an error here, |
|
# in which case the space_action branch needs to be rewritten to handle the existing token_waiting |
|
# --------------------------------------------------------- |
|
|
|
if {$space_action eq "pop"} { |
|
#pop_trigger_tokens: newline tablename endarray endinlinetable |
|
#note a token is a pop trigger depending on context. e.g first newline during keyval is a pop trigger. |
|
set parentlevel [expr {$nest -1}] |
|
set do_append_to_parent 1 ;#most tokens will leave this alone - but some like squote_seq need to do their own append |
|
switch -exact -- $tokenType { |
|
squote_seq { |
|
#### |
|
set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed |
|
#Without this - we would get extraneous empty list entries in the parent |
|
# - as the xxx-squote-space isn't a space level from the toml perspective |
|
# - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop |
|
switch -- $tok { |
|
' { |
|
tomlish::parse::set_token_waiting type startsquote value $tok complete 1 startindex [expr {$i -1}] |
|
} |
|
'' { |
|
#review - we should perhaps return double_squote instead? |
|
#tomlish::parse::set_token_waiting type literal value "" complete 1 |
|
tomlish::parse::set_token_waiting type double_squote value "" complete 1 startindex [expr {$i - 2}] |
|
} |
|
''' { |
|
#### |
|
#if already an eof in token_waiting - set_token_waiting will insert before it |
|
tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 3}] |
|
} |
|
'''' { |
|
switch -exact -- $prevstate { |
|
leading-squote-space { |
|
error "---- 4 squotes from leading-squote-space - shouldn't get here" |
|
#we should have emitted the triple and left the last for next loop |
|
} |
|
trailing-squote-space { |
|
tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 4}] |
|
#todo integrate left squote with nest data at this level |
|
set lastpart [lindex $v($parentlevel) end] |
|
switch -- [lindex $lastpart 0] { |
|
LITERALPART { |
|
set newval "[lindex $lastpart 1]'" |
|
set parentdata $v($parentlevel) |
|
lset parentdata end [list LITERALPART $newval] |
|
set v($parentlevel) $parentdata |
|
} |
|
NEWLINE { |
|
lappend v($parentlevel) [list LITERALPART "'"] |
|
} |
|
default { |
|
error "--- don't know how to integrate extra trailing squote with data $v($parentlevel)" |
|
} |
|
} |
|
} |
|
default { |
|
error "--- unexpected popped due to squote_seq but came from state '$prevstate' should have been leading-squote-space or trailing-squote-space" |
|
} |
|
} |
|
} |
|
''''' { |
|
switch -exact -- $prevstate { |
|
leading-squote-space { |
|
error "---- 5 squotes from leading-squote-space - shouldn't get here" |
|
#we should have emitted the triple and left the following squotes for next loop |
|
} |
|
trailing-squote-space { |
|
tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i-5}] |
|
#todo integrate left 2 squotes with nest data at this level |
|
set lastpart [lindex $v($parentlevel) end] |
|
switch -- [lindex $lastpart 0] { |
|
LITERALPART { |
|
set newval "[lindex $lastpart 1]''" |
|
set parentdata $v($parentlevel) |
|
lset parentdata end [list LITERALPART $newval] |
|
set v($parentlevel) $parentdata |
|
} |
|
NEWLINE { |
|
lappend v($parentlevel) [LITERALPART "''"] |
|
} |
|
default { |
|
error "--- don't know how to integrate extra trailing 2 squotes with data $v($parentlevel)" |
|
} |
|
} |
|
} |
|
default { |
|
error "--- unexpected popped due to squote_seq but came from state '$prevstate' should have been leading-squote-space or trailing-squote-space" |
|
} |
|
} |
|
} |
|
} |
|
puts "---- HERE squote_seq pop <$tok>" |
|
} |
|
triple_squote { |
|
#presumably popping multiliteral-space |
|
::tomlish::log::debug "---- triple_squote for last_space_action pop leveldata: $v($nest)" |
|
set merged [list] |
|
set lasttype "" |
|
foreach part $v($nest) { |
|
switch -exact -- [lindex $part 0] { |
|
MULTILITERAL { |
|
lappend merged $part |
|
} |
|
LITERALPART { |
|
if {$lasttype eq "LITERALPART"} { |
|
set prevpart [lindex $merged end] |
|
lset prevpart 1 [lindex $prevpart 1][lindex $part 1] |
|
lset merged end $prevpart |
|
} else { |
|
lappend merged $part |
|
} |
|
} |
|
NEWLINE { |
|
#note that even though first newline ultimately gets stripped from multiliterals - that isn't done here |
|
#we still need the first one for roundtripping. The datastructure stage is where it gets stripped. |
|
lappend merged $part |
|
} |
|
default { |
|
error "---- triple_squote unhandled part type [lindex $part 0] unable to merge leveldata: $v($next)" |
|
} |
|
} |
|
set lasttype [lindex $part 0] |
|
} |
|
set v($nest) $merged |
|
} |
|
equal { |
|
if {$prevstate eq "dottedkey-space"} { |
|
tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" |
|
#re-emit for parent space |
|
tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] |
|
} |
|
} |
|
newline { |
|
incr linenum |
|
lappend v($nest) [list NEWLINE $tok] |
|
} |
|
tablename { |
|
#note: a tablename only 'pops' if we are greater than zero |
|
error "---- tablename pop should already have been handled as special case zeropoppushspace in goNextState" |
|
} |
|
tablearrayname { |
|
#!review - tablearrayname different to tablename regarding push/pop? |
|
#note: a tablename only 'pops' if we are greater than zero |
|
error "---- tablearrayname pop should already have been handled as special case zeropoppushspace in goNextState" |
|
} |
|
endarray { |
|
#nothing to do here. |
|
} |
|
comma { |
|
#comma for inline table will pop the keyvalue space |
|
lappend v($nest) "SEP" |
|
} |
|
endinlinetable { |
|
::tomlish::log::debug "---- endinlinetable for last_space_action pop" |
|
} |
|
endmultiquote { |
|
::tomlish::log::debug "---- endmultiquote for last_space_action 'pop'" |
|
} |
|
default { |
|
error "---- unexpected tokenType '$tokenType' for last_space_action 'pop'" |
|
} |
|
} |
|
if {$do_append_to_parent} { |
|
#e.g squote_seq does it's own appends as necessary - so won't get here |
|
lappend v($parentlevel) [set v($nest)] |
|
} |
|
|
|
incr nest -1 |
|
|
|
} elseif {$last_space_action eq "push"} { |
|
set prevnest $nest |
|
incr nest 1 |
|
set v($nest) [list] |
|
# push_trigger_tokens: barekey quotedkey startinlinetable startarray tablename tablearrayname |
|
|
|
|
|
switch -exact -- $tokenType { |
|
squote_seq_begin { |
|
#### |
|
if {[dict exists $transition_info starttok] && [dict get $transition_info starttok] ne ""} { |
|
lassign [dict get $transition_info starttok] starttok_type starttok_val |
|
set next_tokenType_known 1 |
|
::tomlish::parse::set_tokenType $starttok_type |
|
set tok $starttok_val |
|
} |
|
} |
|
squotedkey { |
|
switch -exact -- $prevstate { |
|
table-space - itable-space { |
|
set v($nest) [list DOTTEDKEY] |
|
} |
|
} |
|
#todo - check not something already waiting? |
|
tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space |
|
} |
|
barekey { |
|
switch -exact -- $prevstate { |
|
table-space - itable-space { |
|
set v($nest) [list DOTTEDKEY] |
|
} |
|
} |
|
#todo - check not something already waiting? |
|
set waiting [tomlish::parse::get_token_waiting] |
|
if {[llength $waiting]} { |
|
set i [dict get $waiting startindex] |
|
tomlish::parse::clear_token_waiting |
|
tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space |
|
} else { |
|
tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space |
|
} |
|
} |
|
startsquote { |
|
set next_tokenType_known 1 |
|
::tomlish::parse::set_tokenType "squotedkey" |
|
set tok "" |
|
} |
|
quotedkey - itablequotedkey { |
|
set v($nest) [list QKEY $tok] ;#$tok is the keyname |
|
} |
|
itablesquotedkey { |
|
set v($nest) [list SQKEY $tok] ;#$tok is the keyname |
|
} |
|
tablename { |
|
#note: we do not use the output of tomlish::tablename_trim to produce a tablename for storage in the tomlish list! |
|
#The tomlish list is intended to preserve all whitespace (and comments) - so a roundtrip from toml file to tomlish |
|
# back to toml file will be identical. |
|
#It is up to the datastructure stage to normalize and interpret tomlish for programmatic access. |
|
# we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, |
|
# so we can raise an error at this point rather than create a tomlish list with obviously invalid table names. |
|
|
|
#todo - review! It's arguable that we should not do any validation here, and just store even incorrect raw tablenames, |
|
# so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the |
|
# tomlish list? |
|
|
|
set test_only [::tomlish::utils::tablename_trim $tok] |
|
::tomlish::log::debug "---- trimmed (but not normalized) tablename: '$test_only'" |
|
set v($nest) [list TABLE $tok] ;#$tok is the *raw* table name |
|
#note also that equivalent tablenames may have different toml representations even after being trimmed! |
|
#e.g ["x\t\t"] & ["x "] (tab escapes vs literals) |
|
#These will show as above in the tomlish list, but should normalize to the same tablename when used as keys by the datastructure stage. |
|
} |
|
tablearrayname { |
|
set test_only [::tomlish::utils::tablename_trim $tok] |
|
puts stdout "trimmed (but not normalized) tablearrayname: '$test_only'" |
|
set v($nest) [list TABLEARRAY $tok] ;#$tok is the *raw* tablearray name |
|
} |
|
startarray { |
|
set v($nest) [list ARRAY] ;#$tok is just the opening bracket - don't output. |
|
} |
|
startinlinetable { |
|
set v($nest) [list ITABLE] ;#$tok is just the opening curly brace - don't output. |
|
} |
|
startmultiquote { |
|
::tomlish::log::debug "---- push trigger tokenType startmultiquote" |
|
set v($nest) [list MULTISTRING] ;#container for STRINGPART, WS, CONT, NEWLINE |
|
} |
|
triple_squote { |
|
::tomlish::log::debug "---- push trigger tokenType triple_squote" |
|
set v($nest) [list MULTILITERAL] ;#container for NEWLINE,LITERAL |
|
} |
|
default { |
|
error "---- push trigger tokenType '$tokenType' not yet implemented" |
|
} |
|
} |
|
|
|
} else { |
|
#no space level change |
|
switch -exact -- $tokenType { |
|
squotedkey { |
|
puts "---- squotedkey in state $prevstate (no space level change)" |
|
lappend v($nest) [list SQKEY $tok] |
|
} |
|
barekey { |
|
lappend v($nest) [list KEY $tok] |
|
} |
|
dotsep { |
|
lappend v($nest) [list DOTSEP] |
|
} |
|
starttablename { |
|
#$tok is triggered by the opening bracket and sends nothing to output |
|
} |
|
starttablearrayname { |
|
#$tok is triggered by the double opening brackets and sends nothing to output |
|
} |
|
tablename - tablenamearray { |
|
error "---- did not expect 'tablename/tablearrayname' without space level change (no space level change)" |
|
#set v($nest) [list TABLE $tok] |
|
} |
|
endtablename - endtablearrayname { |
|
#no output into the tomlish list for this token |
|
} |
|
startinlinetable { |
|
puts stderr "---- decode::toml error. did not expect startinlinetable without space level change (no space level change)" |
|
} |
|
startquote { |
|
switch -exact -- $newstate { |
|
string-state { |
|
set next_tokenType_known 1 |
|
::tomlish::parse::set_tokenType "string" |
|
set tok "" |
|
} |
|
quoted-key { |
|
set next_tokenType_known 1 |
|
::tomlish::parse::set_tokenType "quotedkey" |
|
set tok "" |
|
} |
|
itable-quoted-key { |
|
set next_tokenType_known 1 |
|
::tomlish::parse::set_tokenType "itablequotedkey" |
|
set tok "" |
|
} |
|
default { |
|
error "---- startquote switch case not implemented for nextstate: $newstate (no space level change)" |
|
} |
|
} |
|
} |
|
startsquote { |
|
switch -exact -- $newstate { |
|
literal-state { |
|
set next_tokenType_known 1 |
|
::tomlish::parse::set_tokenType "literal" |
|
set tok "" |
|
} |
|
squoted-key { |
|
set next_tokenType_known 1 |
|
::tomlish::parse::set_tokenType "squotedkey" |
|
set tok "" |
|
} |
|
itable-squoted-key { |
|
set next_tokenType_known 1 |
|
::tomlish::parse::set_tokenType "itablesquotedkey" |
|
set tok "" |
|
} |
|
multiliteral-space { |
|
#false alarm squote returned from squote_seq pop |
|
::tomlish::log::debug "---- adding lone squote to own LITERALPART nextstate: $newstate (no space level change)" |
|
#(single squote - not terminating space) |
|
lappend v($nest) [list LITERALPART '] |
|
#may need to be joined on pop if there are neighbouring LITERALPARTs |
|
} |
|
default { |
|
error "---- startsquote switch case not implemented for nextstate: $newstate (no space level change)" |
|
} |
|
} |
|
} |
|
startmultiquote { |
|
#review |
|
puts stderr "---- got startmultiquote in state $prevstate (no space level change)" |
|
set next_tokenType_known 1 |
|
::tomlish::parse::set_tokenType "stringpart" |
|
set tok "" |
|
} |
|
endquote { |
|
#nothing to do? |
|
set tok "" |
|
} |
|
endsquote { |
|
set tok "" |
|
} |
|
endmultiquote { |
|
#JMN!! |
|
set tok "" |
|
} |
|
string { |
|
lappend v($nest) [list STRING $tok] ;#directly wrapped in dquotes |
|
} |
|
literal { |
|
lappend v($nest) [list LITERAL $tok] ;#directly wrapped in squotes |
|
} |
|
double_squote { |
|
switch -exact -- $prevstate { |
|
keyval-value-expected { |
|
lappend v($nest) [list LITERAL ""] |
|
} |
|
multiliteral-space { |
|
#multiliteral-space to multiliteral-space |
|
lappend v($nest) [list LITERALPART ''] |
|
} |
|
default { |
|
error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" |
|
} |
|
} |
|
} |
|
multistring { |
|
#review |
|
lappend v($nest) [list MULTISTRING $tok] |
|
} |
|
stringpart { |
|
lappend v($nest) [list STRINGPART $tok] ;#will not get wrapped in dquotes directly |
|
} |
|
multiliteral { |
|
lappend v($nest) [LIST MULTILITERAL $tok] |
|
} |
|
literalpart { |
|
lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly |
|
} |
|
quotedkey { |
|
#lappend v($nest) [list QKEY $tok] ;#TEST |
|
} |
|
itablequotedkey { |
|
|
|
} |
|
untyped_value { |
|
#we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. |
|
if {$tok in {true false}} { |
|
set tag BOOL |
|
} elseif {[::tomlish::utils::is_int $tok]} { |
|
set tag INT |
|
} elseif {[::tomlish::utils::is_float $tok]} { |
|
set tag FLOAT |
|
} elseif {[::tomlish::utils::is_datetime $tok]} { |
|
set tag DATETIME |
|
} else { |
|
error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" |
|
} |
|
lappend v($nest) [list $tag $tok] |
|
|
|
} |
|
comment { |
|
#puts stdout "----- comment token returned '$tok'------" |
|
lappend v($nest) [list COMMENT "$tok"] |
|
} |
|
equal { |
|
#we append '=' to the nest so that any surrounding whitespace is retained. |
|
lappend v($nest) = |
|
} |
|
comma { |
|
lappend v($nest) SEP |
|
} |
|
newline { |
|
incr linenum |
|
lappend v($nest) [list NEWLINE $tok] |
|
} |
|
whitespace { |
|
lappend v($nest) [list WS $tok] |
|
} |
|
continuation { |
|
lappend v($nest) CONT |
|
} |
|
bom { |
|
lappend v($nest) BOM |
|
} |
|
eof { |
|
#ok - nothing more to add to the tomlish list. |
|
#!todo - check previous tokens are complete/valid? |
|
} |
|
default { |
|
error "--- unknown tokenType '$tokenType' during state $prevstate [::tomlish::parse::report_line] (no space level change)" |
|
} |
|
} |
|
} |
|
|
|
if {!$next_tokenType_known} { |
|
::tomlish::log::notice "---- tomlish::decode::toml - current tokenType:$tokenType Next token type not known" |
|
::tomlish::parse::set_tokenType "" |
|
set tok "" |
|
} |
|
|
|
if {$state eq "end-state"} { |
|
break |
|
} |
|
|
|
|
|
} |
|
|
|
#while {$nest > 0} { |
|
# lappend v([expr {$nest -1}]) [set v($nest)] |
|
# incr nest -1 |
|
#} |
|
while {[::tomlish::parse::spacestack size] > 1} { |
|
::tomlish::parse::spacestack pop |
|
lappend v([expr {$nest -1}]) [set v($nest)] |
|
incr nest -1 |
|
|
|
#set parent [spacestack peek] ;#the level being appended to |
|
#lassign $parent type state |
|
#if {$type eq "space"} { |
|
# |
|
#} elseif {$type eq "buffer"} { |
|
# lappend v([expr {$nest -1}]) {*}[set v($nest)] |
|
#} else { |
|
# error "invalid spacestack item: $parent" |
|
#} |
|
} |
|
|
|
} finally { |
|
set is_parsing 0 |
|
} |
|
return $v(0) |
|
} |
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace tomlish::decode ---}] |
|
} |
|
#decode toml to tomlish |
|
interp alias {} tomlish::from_toml {} tomlish::decode::toml |
|
|
|
namespace eval tomlish::utils { |
|
#*** !doctools |
|
#[subsection {Namespace tomlish::utils}] |
|
#[para] |
|
#[list_begin definitions] |
|
|
|
|
|
#tablenames (& tablearraynames) may contain irrelevant leading, trailing and interspersed whitespace |
|
# tablenames can be made up of segments delimited by dots. .eg [ a.b . c ] |
|
#trimmed, the tablename becomes {a.b.c} |
|
# A segment may contain whitespace if it is quoted e.g [a . b . "c etc " ] |
|
#ie whitespace is only irrelevant if it's outside a quoted segment |
|
#trimmed, the tablename becomes {a.b."c etc "} |
|
proc tablename_trim {tablename} { |
|
set segments [tablename_split $tablename false] |
|
set trimmed_segments [list] |
|
foreach seg $segments { |
|
lappend trimmed_segments [::string trim $seg " \t"] |
|
} |
|
return [join $trimmed_segments .] |
|
} |
|
|
|
#basic generic quote matching for single and double quotes |
|
#note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes |
|
proc tok_in_quotedpart {tok} { |
|
set sLen [tcl::string::length $tok] |
|
set quote_type "" |
|
set had_slash 0 |
|
for {set i 0} {$i < $sLen} {incr i} { |
|
set c [tcl::string::index $tok $i] |
|
if {$quote_type eq ""} { |
|
if {$had_slash} { |
|
#don't enter quote mode |
|
#leave slash_mode because even if current char is slash - it is escaped |
|
set had_slash 0 |
|
} else { |
|
set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] |
|
switch -- $ctype { |
|
dq { |
|
set quote_type dq |
|
} |
|
sq { |
|
set quote_type sq |
|
} |
|
bsl { |
|
set had_slash 1 |
|
} |
|
} |
|
} |
|
} else { |
|
if {$had_slash} { |
|
#don't leave quoted mode |
|
#leave slash_mode because even if current char is slash - it is escaped |
|
set had_slash 0 |
|
} else { |
|
set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] |
|
switch -- $ctype { |
|
dq { |
|
if {$quote_type eq "dq"} { |
|
set quote_type "" |
|
} |
|
} |
|
sq { |
|
if {$quote_type eq "sq"} { |
|
set quote_type "" |
|
} |
|
} |
|
bsl { |
|
set had_slash 1 |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return $quote_type ;#dq | sq |
|
} |
|
|
|
#utils::tablename_split |
|
proc tablename_split {tablename {normalize false}} { |
|
#we can't just split on . because we have to handle quoted segments which may contain a dot. |
|
#eg {dog."tater.man"} |
|
set sLen [tcl::string::length $tablename] |
|
set segments [list] |
|
set mode "unknown" ;#5 modes: unknown, quoted,litquoted, unquoted, syntax |
|
#quoted is for double-quotes, litquoted is for single-quotes (string literal) |
|
set seg "" |
|
for {set i 0} {$i < $sLen} {incr i} { |
|
|
|
if {$i > 0} { |
|
set lastChar [tcl::string::index $tablename [expr {$i - 1}]] |
|
} else { |
|
set lastChar "" |
|
} |
|
|
|
set c [tcl::string::index $tablename $i] |
|
|
|
if {$c eq "."} { |
|
switch -exact -- $mode { |
|
unquoted { |
|
#dot marks end of segment. |
|
lappend segments $seg |
|
set seg "" |
|
set mode "unknown" |
|
} |
|
quoted { |
|
append seg $c |
|
} |
|
unknown { |
|
lappend segments $seg |
|
set seg "" |
|
} |
|
litquoted { |
|
append seg $c |
|
} |
|
default { |
|
#mode: syntax |
|
#we got our dot. - the syntax mode is now satisfied. |
|
set mode "unknown" |
|
} |
|
} |
|
} elseif {($c eq "\"") && ($lastChar ne "\\")} { |
|
if {$mode eq "unknown"} { |
|
if {[tcl::string::trim $seg] ne ""} { |
|
#we don't allow a quote in the middle of a bare key |
|
error "tablename_split. character '\"' invalid at this point in tablename. tablename: '$tablename'" |
|
} |
|
set mode "quoted" |
|
set seg "\"" |
|
} elseif {$mode eq "unquoted"} { |
|
append seg $c |
|
} elseif {$mode eq "quoted"} { |
|
append seg $c |
|
lappend segments $seg |
|
set seg "" |
|
set mode "syntax" ;#make sure we only accept a dot or end-of-data now. |
|
} elseif {$mode eq "litquoted"} { |
|
append seg $c |
|
} elseif {$mode eq "syntax"} { |
|
error "tablename_split. expected whitespace or dot, got double quote. tablename: '$tablename'" |
|
} |
|
} elseif {($c eq "\'")} { |
|
if {$mode eq "unknown"} { |
|
append seg $c |
|
set mode "litquoted" |
|
} elseif {$mode eq "unquoted"} { |
|
#single quote inside e.g o'neill |
|
append seg $c |
|
} elseif {$mode eq "quoted"} { |
|
append seg $c |
|
|
|
} elseif {$mode eq "litquoted"} { |
|
append seg $c |
|
lappend segments $seg |
|
set seg "" |
|
set mode "syntax" |
|
} elseif {$mode eq "syntax"} { |
|
error "tablename_split. expected whitespace or dot, got single quote. tablename: '$tablename'" |
|
} |
|
|
|
} elseif {$c in [list " " \t]} { |
|
if {$mode eq "syntax"} { |
|
#ignore |
|
} else { |
|
append seg $c |
|
} |
|
} else { |
|
if {$mode eq "syntax"} { |
|
error "tablename_split. Expected a dot separator. got '$c'. tablename: '$tablename'" |
|
} |
|
if {$mode eq "unknown"} { |
|
set mode "unquoted" |
|
} |
|
append seg $c |
|
} |
|
if {$i == $sLen-1} { |
|
#end of data |
|
::tomlish::log::debug "End of data: mode='$mode'" |
|
switch -exact -- $mode { |
|
quoted { |
|
if {$c ne "\""} { |
|
error "tablename_split. missing closing double-quote in a segment. tablename: '$tablename'" |
|
} |
|
if {$normalize} { |
|
lappend segments $seg |
|
} else { |
|
lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] |
|
#lappend segments [subst -nocommands -novariables [::string range $seg 1 end-1]] ;#wrong |
|
} |
|
} |
|
litquoted { |
|
set trimmed_seg [tcl::string::trim $seg] |
|
if {[tcl::string::index $trimmed_seg end] ne "\'"} { |
|
error "tablename_split. missing closing single-quote in a segment. tablename: '$tablename'" |
|
} |
|
lappend segments $seg |
|
} |
|
unquoted - unknown { |
|
lappend segments $seg |
|
} |
|
syntax { |
|
#ok - segment already lappended |
|
} |
|
default { |
|
lappend segments $seg |
|
} |
|
} |
|
} |
|
} |
|
foreach seg $segments { |
|
set trimmed [tcl::string::trim $seg " \t"] |
|
#note - we explicitly allow 'empty' quoted strings '' & "" |
|
# (these are 'discouraged' but valid toml keys) |
|
#if {$trimmed in [list "''" "\"\""]} { |
|
# puts stderr "tablename_split. warning - Empty quoted string as tablename segment" |
|
#} |
|
if {$trimmed eq "" } { |
|
error "tablename_split. Empty segment found. tablename: '$tablename' segments [llength $segments] ($segments)" |
|
} |
|
} |
|
return $segments |
|
} |
|
|
|
proc unicode_escape_info {slashu} { |
|
#!todo |
|
# validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and |
|
# is a valid 'unicode scalar value' |
|
# 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" ]] |
|
} |
|
|
|
} |
|
|
|
proc unescape_string {str} { |
|
#note we can't just use Tcl subst because: |
|
# it also transforms \a (audible bell) and \v (vertical tab) which are not in the toml spec. |
|
# it would strip out backslashes inappropriately: e.g "\j" becomes just j |
|
# it recognizes other escapes which aren't approprite e.g \xhh and octal \nnn |
|
# it replaces\<newline><whitespace> with a single whitespace |
|
#This means we shouldn't use 'subst' on the whole string, but instead substitute only the toml-specified escapes (\r \n \b \t \f \\ \" \uhhhh & \Uhhhhhhhh |
|
|
|
set buffer "" |
|
set buffer4 "" ;#buffer for 4 hex characters following a \u |
|
set buffer8 "" ;#buffer for 8 hex characters following a \u |
|
|
|
set sLen [tcl::string::length $str] |
|
|
|
#we need to handle arbitrarily long sequences of backslashes. \\\\\ etc |
|
set slash_active 0 |
|
set unicode4_active 0 |
|
set unicode8_active 0 |
|
|
|
|
|
#!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" |
|
scan $c %c n |
|
if {($n <= 31) && ($n != 9) && ($n != 10) && ($n != 13)} { |
|
#we don't expect unescaped unicode characters from 0000 to 001F - |
|
#*except* for raw tab (which is whitespace) and newlines |
|
error "unescape_string. Invalid data for a toml string. Unescaped control character (decimal $n) [::tomlish::utils::string_to_slashu $c]" |
|
} |
|
incr i ;#must incr here because we do'returns'inside the loop |
|
if {$c eq "\\"} { |
|
if {$slash_active} { |
|
append buffer "\\" |
|
set slash_active 0 |
|
} elseif {$unicode4_active} { |
|
error "unescape_string. unexpected case slash during unicode4 not yet handled" |
|
} elseif {$unicode8_active} { |
|
error "unescape_string. unexpected case slash during unicode8 not yet handled" |
|
} else { |
|
# don't output anything (yet) |
|
set slash_active 1 |
|
} |
|
} else { |
|
if {$unicode4_active} { |
|
if {[tcl::string::length $buffer4] < 4} { |
|
append buffer4 $c |
|
} |
|
if {[tcl::string::length $buffer4] == 4} { |
|
#we have a \uHHHH to test |
|
set unicode4_active 0 |
|
set result [tomlish::utils::unicode_escape_info "\\u$buffer4"] |
|
if {[lindex $result 0] eq "ok"} { |
|
append buffer [dict get $result ok char] |
|
} else { |
|
error "unescape_string error: [lindex $result 1]" |
|
} |
|
} |
|
} elseif {$unicode8_active} { |
|
if {[tcl::string::length $buffer8] < 8} { |
|
append buffer8 $c |
|
} |
|
if {[tcl::string::length $buffer8] == 8} { |
|
#we have a \UHHHHHHHH to test |
|
set unicode8_active 0 |
|
set result [tomlish::utils::unicode_escape_info "\\U$buffer8"] |
|
if {[lindex $result 0] eq "ok"} { |
|
append buffer [dict get $result ok char] |
|
} else { |
|
error "unescape_string error: [lindex $result 1]" |
|
} |
|
} |
|
} elseif {$slash_active} { |
|
set slash_active 0 |
|
set ctest [tcl::string::map {{"} dq} $c] |
|
switch -exact -- $ctest { |
|
dq { |
|
set e "\\\"" |
|
append buffer [subst -nocommand -novariable $e] |
|
} |
|
b - t - n - f - r { |
|
set e "\\$c" |
|
append buffer [subst -nocommand -novariable $e] |
|
} |
|
u { |
|
set unicode4_active 1 |
|
set buffer4 "" |
|
} |
|
U { |
|
set unicode8_active 1 |
|
set buffer8 "" |
|
} |
|
default { |
|
set slash_active 0 |
|
|
|
append buffer "\\" |
|
append buffer $c |
|
} |
|
} |
|
} else { |
|
append buffer $c |
|
} |
|
} |
|
} |
|
#puts stdout "EOF 4:$unicode4_active 8:$unicode8_active slash:$slash_active" |
|
if {$unicode4_active} { |
|
error "End of string reached before complete unicode escape sequence \uHHHH" |
|
} |
|
if {$unicode8_active} { |
|
error "End of string reached before complete unicode escape sequence \UHHHHHHHH" |
|
} |
|
if {$slash_active} { |
|
append buffer "\\" |
|
} |
|
return $buffer |
|
} |
|
|
|
proc normalize_key {rawkey} { |
|
set c1 [tcl::string::index $rawkey 0] |
|
set c2 [tcl::string::index $rawkey end] |
|
if {($c1 eq "'") && ($c2 eq "'")} { |
|
#single quoted segment. No escapes allowed within it. |
|
set key [tcl::string::range $rawkey 1 end-1] |
|
} elseif {($c1 eq "\"") && ($c2 eq "\"")} { |
|
#double quoted segment. Apply escapes. |
|
# |
|
set keydata [tcl::string::range $rawkey 1 end-1] ;#strip outer quotes only |
|
set key [::tomlish::utils::unescape_string $keydata] |
|
#set key [subst -nocommands -novariables $keydata] ;#wrong. Todo - create a string escape substitution function. |
|
} else { |
|
set key $rawkey |
|
} |
|
return $key |
|
} |
|
|
|
proc string_to_slashu {string} { |
|
set rv {} |
|
foreach c [split $string {}] { |
|
scan $c %c c |
|
append rv {\u} |
|
append rv [format %.4X $c] |
|
} |
|
return $rv |
|
} |
|
|
|
#'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. |
|
proc nonprintable_to_slashu {s} { |
|
set res "" |
|
foreach i [split $s ""] { |
|
scan $i %c c |
|
|
|
set printable 0 |
|
if {($c>31) && ($c<127)} { |
|
set printable 1 |
|
} |
|
if {$printable} {append res $i} else {append res \\u[format %.4X $c]} |
|
} |
|
set res |
|
} ;#RS |
|
|
|
#check if str is valid for use as a toml bare key |
|
#Early toml versions? only allowed letters + underscore + dash |
|
proc is_barekey1 {str} { |
|
if {[tcl::string::length $str] == 0} { |
|
return 0 |
|
} else { |
|
set matches [regexp -all {[a-zA-Z0-9\_\-]} $str] |
|
if {[tcl::string::length $str] == $matches} { |
|
#all characters match the regexp |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
} |
|
|
|
#from toml.abnf in github.com/toml-lang/toml |
|
#unquoted-key = 1*unquoted-key-char |
|
#unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ |
|
#unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions |
|
#unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block |
|
#unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon |
|
#unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ |
|
#unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics |
|
#unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces |
|
#unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators |
|
#unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols |
|
#unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation |
|
#unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank |
|
#unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space |
|
#unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) |
|
#unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) |
|
variable re_barekey |
|
set ranges [list] |
|
lappend ranges {a-zA-Z0-9\_\-} |
|
lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions |
|
lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block |
|
lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon |
|
lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ |
|
lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics |
|
lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces |
|
lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators |
|
lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols |
|
lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation |
|
lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank |
|
lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space |
|
lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) |
|
lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) |
|
set re_barekey {^[} |
|
foreach r $ranges { |
|
append re_barekey $r |
|
} |
|
append re_barekey {]+$} |
|
|
|
proc is_barekey {str} { |
|
if {[tcl::string::length $str] == 0} { |
|
return 0 |
|
} |
|
variable re_barekey |
|
return [regexp $re_barekey $str] |
|
} |
|
|
|
#test only that the characters in str are valid for the toml specified type 'integer'. |
|
proc int_validchars1 {str} { |
|
set numchars [tcl::string::length $str] |
|
if {[regexp -all {[0-9\_\-\+]} $str] == $numchars} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
#add support for hex,octal,binary 0x.. 0o.. 0b... |
|
proc int_validchars {str} { |
|
set numchars [tcl::string::length $str] |
|
if {[regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] == $numchars} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
|
|
proc is_int {str} { |
|
set matches [regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] |
|
|
|
if {[tcl::string::length $str] == $matches} { |
|
#all characters in legal range |
|
|
|
# --------------------------------------- |
|
#check for leading zeroes in non 0x 0b 0o |
|
#first strip any +, - or _ (just for this test) |
|
set check [tcl::string::map {+ "" - "" _ ""} $str] |
|
if {([tcl::string::length $check] > 1) && ([tcl::string::index $check 0] eq "0") && ([tcl::string::index $check 1] ni {o x b})} { |
|
return 0 |
|
} |
|
# --------------------------------------- |
|
|
|
#check +,- only occur in the first position. |
|
if {[tcl::string::last - $str] > 0} { |
|
return 0 |
|
} |
|
if {[tcl::string::last + $str] > 0} { |
|
return 0 |
|
} |
|
set numeric_value [tcl::string::map {_ ""} $str] ;#allow some earlier tcl versions which don't support underscores |
|
#use Tcl's integer check to ensure we don't let things like 3e4 through - which is a float (would need to be 0x3e4 for hex) |
|
if {![tcl::string::is integer -strict $numeric_value]} { |
|
return 0 |
|
} |
|
#!todo - check bounds only based on some config value |
|
#even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements. |
|
#presumably very large numbers would have to be supplied in a toml file as strings. |
|
#Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max |
|
if {$numeric_value > $::tomlish::max_int} { |
|
return 0 |
|
} |
|
if {$numeric_value < $::tomlish::min_int} { |
|
return 0 |
|
} |
|
} else { |
|
return 0 |
|
} |
|
#Got this far - didn't find anything wrong with it. |
|
return 1 |
|
} |
|
|
|
#test only that the characters in str are valid for the toml specified type 'float'. |
|
proc float_validchars {str} { |
|
set numchars [tcl::string::length $str] |
|
if {[regexp -all {[eE0-9\_\-\+\.]} $str] == $numchars} { |
|
return 1 |
|
} else { |
|
#only allow lower case for these special values - as per Toml 1.0 spec |
|
if {$str ni {inf +inf -inf nan +nan -nan}} { |
|
return 0 |
|
} else { |
|
return 1 |
|
} |
|
} |
|
} |
|
|
|
proc is_float {str} { |
|
set matches [regexp -all {[eE0-9\_\-\+\.]} $str] |
|
#don't test for case variations - as Toml doesn't allow (whereas Tcl allows Inf NaN etc) |
|
if {$str in {inf +inf -inf nan +nan -nan}} { |
|
return 1 |
|
} |
|
|
|
if {[tcl::string::length $str] == $matches} { |
|
#all characters in legal range |
|
#A leading zero is ok, but we should disallow multiple leading zeroes (same rules as toml ints) |
|
#Toml spec also disallows leading zeros in the exponent part |
|
#... but this seems less interoperable (some libraries generate leading zeroes in exponents) |
|
#for now we will allow leading zeros in exponents |
|
#!todo - configure 'strict' option to disallow? |
|
#first strip any +, - or _ (just for this test) |
|
set check [tcl::string::map {+ "" - "" _ ""} $str] |
|
set r {([0-9])*} |
|
regexp $r $check intpart ;#intpart holds all numerals before the first .,e or E |
|
set z {([0])*} |
|
regexp $z $intpart leadingzeros |
|
if {[tcl::string::length $leadingzeros] > 1} { |
|
return 0 |
|
} |
|
#for floats, +,- may occur in multiple places |
|
#e.g -2E-22 +3e34 |
|
#!todo - check bounds ? |
|
|
|
#strip underscores for tcl double check |
|
set check [tcl::string::map {_ ""} $str] |
|
#string is double accepts inf nan +NaN etc. |
|
if {![tcl::string::is double $check]} { |
|
return 0 |
|
} |
|
|
|
} else { |
|
return 0 |
|
} |
|
#Got this far - didn't find anything wrong with it. |
|
return 1 |
|
} |
|
|
|
#test only that the characters in str are valid for the toml specified type 'datetime'. |
|
proc datetime_validchars {str} { |
|
set numchars [tcl::string::length $str] |
|
if {[regexp -all {[zZtT0-9\-\+\.:]} $str] == $numchars} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
|
|
#review - we |
|
proc is_datetime {str} { |
|
#e.g 1979-05-27 |
|
#e.g 1979-05-27T00:32:00Z |
|
#e.g 1979-05-27 00:32:00-07:00 |
|
#e.g 1979-05-27 00:32:00+10:00 |
|
#e.g 1979-05-27 00:32:00.999999-07:00 |
|
|
|
#review |
|
#minimal datetimes? |
|
# 2024 ok - shortest valid 4 digit year? |
|
# 02:00 ok |
|
# 05-17 ok |
|
if {[string length $str] < 4} { |
|
return 0 |
|
} |
|
|
|
set matches [regexp -all {[zZtT0-9\-\+\.:]} $str] |
|
if {[tcl::string::length $str] == $matches} { |
|
#all characters in legal range |
|
#!todo - use full RFC 3339 parser? |
|
lassign [split $str T] datepart timepart |
|
#!todo - what if the value is 'time only'? |
|
|
|
#Tcl's free-form clock scan (no -format option) is deprecated |
|
# |
|
#if {[catch {clock scan $datepart} err]} { |
|
# puts stderr "tcl clock scan failed err:'$err'" |
|
# return 0 |
|
#} |
|
|
|
#!todo - verify time part is reasonable |
|
} else { |
|
return 0 |
|
} |
|
return 1 |
|
} |
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace tomlish::utils ---}] |
|
} |
|
|
|
namespace eval tomlish::parse { |
|
#*** !doctools |
|
#[subsection {Namespace tomlish::parse}] |
|
#[para] |
|
#[list_begin definitions] |
|
|
|
#This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases. |
|
#The code is a pig's-nest - but it should be noted that for example trailing single double quotes in multiline strings are perhaps not so trivial to parse using more standard methods either: |
|
# - e.g some kind of backtracking required if using an ABNF parser? |
|
#I don't know the precise technical name for this sort of parser; probably something like "Dog's Breakfast" |
|
#More seriously, we don't have distinct lex/parse steps - so it is basically a 'fused lexer' or 'scannerless parser' |
|
|
|
#It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? |
|
|
|
#A possible alternative more structured approach might be to use a PEG (Parsing Expression Grammar) |
|
|
|
|
|
variable is_parsing 0 ;#whether we are in the middle of parsing tomlish text |
|
|
|
variable state |
|
# states: |
|
# table-space, itable-space, array-space |
|
# value-expected, keyval-syntax, |
|
# quoted-key, squoted-key |
|
# string-state, literal-state, multistring... |
|
# |
|
# notes: |
|
# only the -space states are also 'spaces' ie a container which is pushed/popped on the spacestack |
|
|
|
# |
|
# value-expected - we also allow for leading whitespace in this state, but once a value is returned we jump to a state based on the containing space. e.g keyval-tail or array-syntax |
|
# |
|
#stateMatrix defines for each state, actions to take for each possible token. |
|
#single-element actions are the name of the next state into which to transition, or a 'POPSPACE' instruction to pop a level off the spacestack and add the data to the parent container. |
|
#dual-element actions are a push instruction and the name of the space to push on the stack. |
|
# - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) |
|
|
|
# -- --- --- --- --- --- |
|
#token/state naming guide |
|
# -- --- --- --- --- --- |
|
#tokens : underscore separated or bare name e.g newline, start_quote, start_squote |
|
#private tokens: always have a leading underscore (These are private 'temporary state' tokens that are never returned as actual tokens e.g _start_squote_sequence |
|
#states : always contain at least one dash e.g err-state, table-space |
|
#instructions |
|
# -- --- --- --- --- --- |
|
|
|
|
|
#stateMatrix dict of elements mapping current state to next state based on returned tokens |
|
# current-state {token-encountered next-state ... } |
|
# where next-state can be a 1 or 2 element list. |
|
#If 2 element - the first item is an instruction (ucase) |
|
#If 1 element - it is either a lowercase dashed state name or an ucase instruction |
|
#e.g {PUSHSPACE <state-space>} or POPSPACE or SAMESPACE |
|
|
|
|
|
#SAMESPACE - got to same space as parent without popping a level, but has it's own autotransition lookup - strange concept - review usecases |
|
|
|
variable stateMatrix |
|
set stateMatrix [dict create] |
|
|
|
#xxx-space vs xxx-syntax inadequately documented - TODO |
|
|
|
# --------------------------------------------------------------------------------------------------------------# |
|
# incomplete example of some state starting at table-space |
|
# --------------------------------------------------------------------------------------------------------------# |
|
# ( = -> value-expected) |
|
# keyval-syntax (popped -> keyval-space -> keyval-tail) (autotransition on pop) |
|
# keyval-space (autotransition on push ^) |
|
# table-space (barekey^) (startquote -> quoted-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 ""}\ |
|
startquote "quoted-key"\ |
|
XXXstartsquote "squoted-key"\ |
|
comment "table-space"\ |
|
starttablename "tablename-state"\ |
|
starttablearrayname "tablearrayname-state"\ |
|
startmultiquote "err-state"\ |
|
endquote "err-state"\ |
|
comma "err-state"\ |
|
eof "end-state"\ |
|
equal "err-state"\ |
|
} |
|
|
|
#itable-space/ curly-syntax : itables |
|
dict set stateMatrix\ |
|
itable-space {\ |
|
whitespace "itable-space"\ |
|
newline "itable-space"\ |
|
squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-space starttok {squote_seq "'"}}\ |
|
barekey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ |
|
squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ |
|
endinlinetable "POPSPACE"\ |
|
startquote "quoted-key"\ |
|
startsquote {TOSTATE "squoted-key" comment "jn-testing"}\ |
|
comma "itable-space"\ |
|
comment "err-state"\ |
|
eof "err-state"\ |
|
} |
|
|
|
|
|
dict set stateMatrix\ |
|
keyval-space {\ |
|
whitespace "keyval-syntax"\ |
|
equal "keyval-value-expected"\ |
|
} |
|
|
|
# ' = ' portion of keyval |
|
dict set stateMatrix\ |
|
keyval-syntax {\ |
|
whitespace "keyval-syntax"\ |
|
squotedkey {PUSHSPACE "dottedkey-space"}\ |
|
barekey {PUSHSPACE "dottedkey-space"}\ |
|
equal "keyval-value-expected"\ |
|
comma "err-state"\ |
|
newline "err-state"\ |
|
eof "err-state"\ |
|
} |
|
#### |
|
dict set stateMatrix\ |
|
keyval-value-expected {\ |
|
whitespace "keyval-value-expected"\ |
|
untyped_value {TOSTATE "keyval-tail" note ""}\ |
|
squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate keyval-value-expected starttok {squote_seq "'"}}\ |
|
startquote {TOSTATE "string-state" returnstate keyval-tail}\ |
|
startmultiquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ |
|
startsquote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ |
|
double_squote {TOSTATE "keyval-tail" note "empty literal received when double squote occurs"}\ |
|
triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ |
|
startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ |
|
startarray {PUSHSPACE array-space returnstate keyval-tail}\ |
|
} |
|
#squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate keyval-process-leading-squotes starttok {squote_seq "'"}} |
|
dict set stateMatrix\ |
|
leading-squote-space {\ |
|
squote_seq "POPSPACE"\ |
|
} |
|
#dict set stateMatrix\ |
|
# keyval-process-leading-squotes {\ |
|
# startsquote "literal-state"\ |
|
# triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ |
|
# } |
|
|
|
dict set stateMatrix\ |
|
keyval-tail {\ |
|
whitespace "keyval-tail"\ |
|
newline "POPSPACE"\ |
|
comment "keyval-tail"\ |
|
eof "end-state"\ |
|
} |
|
|
|
dict set stateMatrix\ |
|
itable-keyval-syntax {\ |
|
whitespace "itable-keyval-syntax"\ |
|
squotedkey {PUSHSPACE "dottedkey-space"}\ |
|
barekey {PUSHSPACE "dottedkey-space"}\ |
|
equal "itable-keyval-value-expected"\ |
|
newline "err-state"\ |
|
eof "err-state"\ |
|
} |
|
dict set stateMatrix\ |
|
itable-keyval-value-expected {\ |
|
whitespace "itable-keyval-value-expected"\ |
|
untyped_value {TOSTATE "itable-val-tail" note ""}\ |
|
squote_seq_begin {PUSHSPACE "leading-squote-space" returnstate itable-keyval-value-expected starttok {squote_seq "'"}}\ |
|
startquote {TOSTATE "string-state" returnstate itable-val-tail}\ |
|
startmultiquote {PUSHSPACE "multistring-space" returnstate itable-val-tail}\ |
|
startsquote {TOSTATE "literal-state" returnstate itable-val-tail note "usual way a literal is triggered"}\ |
|
double_squote {TOSTATE "itable-val-tail" note "empty literal received when double squote occurs"}\ |
|
triple_squote {PUSHSPACE "multiliteral-space" returnstate itable-val-tail}\ |
|
startinlinetable {PUSHSPACE "itable-space" returnstate itable-val-tail}\ |
|
startarray {PUSHSPACE "array-space" returnstate itable-val-tail}\ |
|
} |
|
dict set stateMatrix\ |
|
itable-keyval-space {\ |
|
whitespace "itable-keyval-syntax"\ |
|
equal {TOSTATE "itable-keyval-value-expected" note "required"}\ |
|
} |
|
|
|
dict set stateMatrix\ |
|
itable-val-tail {\ |
|
whitespace "itable-val-tail"\ |
|
endinlinetable "POPSPACE"\ |
|
comma "POPSPACE"\ |
|
Xnewline {TOSTATE "itable-val-tail" note "itable-space ??"}\ |
|
newline "err-state"\ |
|
comment "itable-val-tail"\ |
|
eof "err-state"\ |
|
} |
|
#dict set stateMatrix\ |
|
# itable-quoted-key {\ |
|
# whitespace "NA"\ |
|
# itablequotedkey {PUSHSPACE "itable-keyval-space"}\ |
|
# newline "err-state"\ |
|
# endquote "itable-keyval-syntax"\ |
|
# } |
|
#dict set stateMatrix\ |
|
# itable-squoted-key {\ |
|
# whitespace "NA"\ |
|
# itablesquotedkey {PUSHSPACE "itable-keyval-space"}\ |
|
# newline "err-state"\ |
|
# endsquote "itable-keyval-syntax"\ |
|
# } |
|
|
|
|
|
|
|
|
|
|
|
dict set stateMatrix\ |
|
value-expected {\ |
|
whitespace "value-expected"\ |
|
untyped_value {"SAMESPACE" "" replay untyped_value}\ |
|
startquote "string-state"\ |
|
startsquote "literal-state"\ |
|
startmultiquote {PUSHSPACE "multistring-space"}\ |
|
triple_squote {PUSHSPACE "multiliteral-space"}\ |
|
startinlinetable {PUSHSPACE itable-space}\ |
|
startarray {PUSHSPACE array-space}\ |
|
comment "err-state-value-expected-got-comment"\ |
|
comma "err-state"\ |
|
newline "err-state"\ |
|
eof "err-state"\ |
|
} |
|
|
|
#dottedkey-space is not used within [tablename] or [[tablearrayname]] |
|
#it is for keyval ie x.y.z = value |
|
dict set stateMatrix\ |
|
dottedkey-space {\ |
|
whitespace "dottedkey-space"\ |
|
dotsep "dottedkey-space"\ |
|
barekey "dottedkey-space"\ |
|
squotedkey "dottedkey-space"\ |
|
quotedkey "dottedkey-space"\ |
|
equal "POPSPACE"\ |
|
newline "err-state"\ |
|
comma "err-state"\ |
|
comment "err-state"\ |
|
} |
|
#dottedkeyend "POPSPACE" |
|
|
|
|
|
|
|
|
|
#REVIEW |
|
#toml spec looks like heading towards allowing newlines within inline tables |
|
#https://github.com/toml-lang/toml/issues/781 |
|
dict set stateMatrix\ |
|
curly-syntax {\ |
|
whitespace "curly-syntax"\ |
|
newline "curly-syntax"\ |
|
barekey {PUSHSPACE "itable-keyval-space"}\ |
|
itablequotedkey "itable-keyval-space"\ |
|
endinlinetable "POPSPACE"\ |
|
startquote "itable-quoted-key"\ |
|
comma "itable-space"\ |
|
comment "itable-space"\ |
|
eof "err-state"\ |
|
} |
|
#review comment "err-state" vs comment "itable-space" - see if TOML 1.1 comes out and allows comments in multiline ITABLES |
|
#We currently allow multiline ITABLES (also with comments) in the tokenizer. |
|
#if we want to disallow as per TOML 1.0 - we should do so when attempting to get structure? |
|
|
|
|
|
#JMN REVIEW |
|
dict set stateMatrix\ |
|
array-space {\ |
|
whitespace "array-space"\ |
|
newline "array-space"\ |
|
untyped_value "SAMESPACE"\ |
|
startarray {PUSHSPACE "array-space"}\ |
|
endarray "POPSPACE"\ |
|
startmultiquote {PUSHSPACE multistring-space}\ |
|
startinlinetable {PUSHSPACE itable-space}\ |
|
startquote "string-state"\ |
|
startsquote "literal-state"\ |
|
triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax note "seems ok 2024"}\ |
|
comma "array-space"\ |
|
comment "array-space"\ |
|
eof "err-state-array-space-got-eof"\ |
|
} |
|
dict set stateMatrix\ |
|
array-syntax {\ |
|
whitespace "array-syntax"\ |
|
newline "array-syntax"\ |
|
untyped_value "SAMESPACE"\ |
|
startarray {PUSHSPACE array-space}\ |
|
endarray "POPSPACE"\ |
|
startmultiquote {PUSHSPACE multistring-space}\ |
|
startquote "string-state"\ |
|
startsquote "literal-state"\ |
|
comma "array-space"\ |
|
comment "err-state"\ |
|
} |
|
|
|
|
|
|
|
#quoted-key & squoted-key need to PUSHSPACE from own token to keyval-space |
|
dict set stateMatrix\ |
|
quoted-key {\ |
|
whitespace "NA"\ |
|
quotedkey {PUSHSPACE "keyval-space"}\ |
|
newline "err-state"\ |
|
endquote "keyval-syntax"\ |
|
} |
|
dict set stateMatrix\ |
|
squoted-key {\ |
|
whitespace "NA"\ |
|
squotedkey "squoted-key"\ |
|
newline "err-state"\ |
|
} |
|
# endsquote {PUSHSPACE "keyval-space"} |
|
|
|
dict set stateMatrix\ |
|
string-state {\ |
|
whitespace "NA"\ |
|
string "string-state"\ |
|
endquote "SAMESPACE"\ |
|
newline "err-state"\ |
|
eof "err-state"\ |
|
} |
|
dict set stateMatrix\ |
|
literal-state {\ |
|
whitespace "NA"\ |
|
literal "literal-state"\ |
|
endsquote "SAMESPACE"\ |
|
newline "err-state"\ |
|
eof "err-state"\ |
|
} |
|
|
|
|
|
#dict set stateMatrix\ |
|
# stringpart {\ |
|
# continuation "SAMESPACE"\ |
|
# endmultiquote "POPSPACE"\ |
|
# eof "err-state"\ |
|
# } |
|
dict set stateMatrix\ |
|
multistring-space {\ |
|
whitespace "multistring-space"\ |
|
continuation "multistring-space"\ |
|
stringpart "multistring-space"\ |
|
newline "multistring-space"\ |
|
endmultiquote "POPSPACE"\ |
|
eof "err-state"\ |
|
} |
|
|
|
|
|
#only valid subparts are literalpart and newline. other whitespace etc is within literalpart |
|
#todo - treat sole cr as part of literalpart but crlf and lf as newline |
|
dict set stateMatrix\ |
|
multiliteral-space {\ |
|
literalpart "multiliteral-space"\ |
|
newline "multiliteral-space"\ |
|
squote_seq_begin {PUSHSPACE "trailing-squote-space" returnstate multiliteral-space starttok {squote_seq "'"}}\ |
|
triple_squote {POPSPACE note "on popping - we do any necessary concatenation of LITERALPART items due to squote processing"}\ |
|
double_squote {TOSTATE multiliteral-space note "short squote_seq: can occur anywhere in the space e.g emitted at end when 5 squotes occur"}\ |
|
startsquote {TOSTATE multiliteral-space note "short squote_seq: same as double_squote - false alarm"}\ |
|
eof "err-premature-eof-in-multiliteral-space"\ |
|
} |
|
|
|
#trailing because we are looking for possible terminating ''' - but must accept '''' or ''''' and re-integrate the 1st one or 2 extra squotes |
|
dict set stateMatrix\ |
|
trailing-squote-space {\ |
|
squote_seq "POPSPACE"\ |
|
} |
|
|
|
|
|
dict set stateMatrix\ |
|
tablename-state {\ |
|
whitespace "NA"\ |
|
tablename {zeropoppushspace table-space}\ |
|
tablename2 {PUSHSPACE table-space}\ |
|
endtablename "tablename-tail"\ |
|
comma "err-state"\ |
|
newline "err-state"\ |
|
} |
|
dict set stateMatrix\ |
|
tablearrayname-state {\ |
|
whitespace "NA"\ |
|
tablearrayname {zeropoppushspace table-space}\ |
|
tablearrayname2 {PUSHSPACE table-space}\ |
|
endtablearray "tablearrayname-tail"\ |
|
comma "err-state"\ |
|
newline "err-state"\ |
|
} |
|
|
|
dict set stateMatrix\ |
|
tablename-tail {\ |
|
whitespace "tablename-tail"\ |
|
newline "table-space"\ |
|
comment "tablename-tail"\ |
|
eof "end-state"\ |
|
} |
|
dict set stateMatrix\ |
|
tablearrayname-tail {\ |
|
whitespace "tablearrayname-tail"\ |
|
newline "table-space"\ |
|
comment "tablearrayname-tail"\ |
|
eof "end-state"\ |
|
} |
|
dict set stateMatrix\ |
|
end-state {} |
|
|
|
set knowntokens [list] |
|
set knownstates [list] |
|
dict for {state transitions} $stateMatrix { |
|
if {$state ni $knownstates} {lappend knownstates $state} |
|
dict for {tok instructions} $transitions { |
|
if {$tok ni $knowntokens} {lappend knowntokens $tok} |
|
} |
|
} |
|
dict set stateMatrix nostate {} |
|
foreach tok $knowntokens { |
|
dict set stateMatrix nostate $tok "err-nostate-received-token-$tok" |
|
} |
|
|
|
|
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
#purpose - debugging? remove? |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
#build a list of 'push triggers' from the stateMatrix |
|
# ie tokens which can push a new space onto spacestack |
|
set push_trigger_tokens [list] |
|
tcl::dict::for {s transitions} $stateMatrix { |
|
tcl::dict::for {token transition_to} $transitions { |
|
set instruction [lindex $transition_to 0] |
|
switch -exact -- $instruction { |
|
PUSHSPACE - zeropoppushspace { |
|
if {$token ni $push_trigger_tokens} { |
|
lappend push_trigger_tokens $token |
|
} |
|
} |
|
} |
|
} |
|
} |
|
::tomlish::log::debug "push_trigger_tokens: $push_trigger_tokens" |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
|
|
|
|
|
|
#This seems hacky... (deprecate in favour of explicit arguments to the instructions in stateMatrix?) |
|
#spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE |
|
|
|
#mainly for the -space states: |
|
#redirect to another state $c based on a state transition from $whatever to $b |
|
# e.g "string {array-space array-syntax}" means when transitioning from string to array-space, jump to array-syntax instead. |
|
#this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' |
|
|
|
#Push to, next |
|
#default first states when we push to these spaces |
|
variable spacePushTransitions { |
|
keyval-space keyval-syntax |
|
itable-keyval-space itable-keyval-syntax |
|
array-space array-space |
|
table-space tablename-state |
|
} |
|
#itable-space itable-space |
|
#Pop to, next |
|
variable spacePopTransitions { |
|
array-space array-syntax |
|
} |
|
#itable-space curly-syntax |
|
#itable-keyval-space itable-val-tail |
|
#review |
|
#we pop to keyval-space from dottedkey-space or from value-expected? we don't always want to go to keyval-tail |
|
#leave it out and make the POPSPACE caller explicitly specify it |
|
#keyval-space keyval-tail |
|
|
|
variable spaceSameTransitions { |
|
array-space array-syntax |
|
} |
|
#itable-space curly-syntax |
|
#itable-keyval-space itable-val-tail |
|
|
|
|
|
variable state_list ;#reset every tomlish::decode::toml |
|
|
|
namespace export tomlish toml |
|
namespace ensemble create |
|
|
|
#goNextState has various side-effects e.g pushes and pops spacestack |
|
#REVIEW - setting nest and v elements here is ugly |
|
#todo - make neater, more single-purpose? |
|
proc goNextState {tokentype tok currentstate} { |
|
variable state |
|
variable nest |
|
variable v |
|
|
|
set prevstate $currentstate |
|
|
|
|
|
variable spacePopTransitions |
|
variable spacePushTransitions |
|
variable spaceSameTransitions |
|
|
|
variable last_space_action "none" |
|
variable last_space_type "none" |
|
variable state_list |
|
|
|
set result "" |
|
set starttok "" |
|
|
|
if {[dict exists $::tomlish::parse::stateMatrix $currentstate $tokentype]} { |
|
set transition_to [dict get $::tomlish::parse::stateMatrix $currentstate $tokentype] |
|
::tomlish::log::debug "--->> goNextState tokentype:$tokentype tok:$tok currentstate:$currentstate : transition_to = $transition_to" |
|
switch -exact -- [lindex $transition_to 0] { |
|
POPSPACE { |
|
spacestack pop |
|
set parent_info [spacestack peek] |
|
set type [dict get $parent_info type] |
|
set parentspace [dict get $parent_info state] |
|
|
|
set last_space_action "pop" |
|
set last_space_type $type |
|
|
|
if {[dict exists $parent_info returnstate]} { |
|
set next [dict get $parent_info returnstate] |
|
#clear the returnstate on current level |
|
set existing [spacestack pop] |
|
dict unset existing returnstate |
|
spacestack push $existing ;#re-push modification |
|
::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace redirected to stored returnstate $next <<---" |
|
} else { |
|
### |
|
#review - do away with spacePopTransitions - which although useful to provide a default.. |
|
# - involve error-prone configurations distant to the main state transition configuration in stateMatrix |
|
if {[dict exists $::tomlish::parse::spacePopTransitions $parentspace]} { |
|
set next [dict get $::tomlish::parse::spacePopTransitions $parentspace] |
|
::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace redirected state to $next (spacePopTransitions)<<---" |
|
} else { |
|
set next $parentspace |
|
::tomlish::log::info "--->> POPSPACE transition to parent space $parentspace<<---" |
|
} |
|
} |
|
set result $next |
|
} |
|
SAMESPACE { |
|
set currentspace_info [spacestack peek] |
|
::tomlish::log::debug "--->> SAMESPACE got current space entry: $currentspace_info <<<<<" |
|
set type [dict get $currentspace_info type] |
|
set currentspace [dict get $currentspace_info state] |
|
|
|
if {[dict exists $currentspace_info returnstate]} { |
|
set next [dict get $currentspace_info returnstate] |
|
#clear the returnstate on current level |
|
set existing [spacestack pop] |
|
dict unset existing returnstate |
|
spacestack push $existing ;#re-push modification |
|
::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected to stored returnstate $next" |
|
} else { |
|
if {[dict exists $::tomlish::parse::spaceSameTransitions $currentspace]} { |
|
set next [dict get $::tomlish::parse::spaceSameTransitions $currentspace] |
|
::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected state to $next (spaceSameTransitions)" |
|
} else { |
|
set next $currentspace |
|
::tomlish::log::info "--->> SAMESPACE transition to space $currentspace" |
|
} |
|
} |
|
set result $next |
|
} |
|
zeropoppushspace { |
|
if {$nest > 0} { |
|
#pop back down to the root level (table-space) |
|
spacestack pop |
|
set parentinfo [spacestack peek] |
|
set type [dict get $parentinfo type] |
|
set target [dict get $parentinfo state] |
|
|
|
set last_space_action "pop" |
|
set last_space_type $type |
|
|
|
#----- |
|
#standard pop |
|
set parentlevel [expr {$nest -1}] |
|
lappend v($parentlevel) [set v($nest)] |
|
incr nest -1 |
|
#----- |
|
} |
|
#re-entrancy |
|
|
|
#set next [list PUSHSPACE [lindex $transition_to 1]] |
|
set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 |
|
#::tomlish::log::notice "goNextState REENTRANCY. calling goNextState $nexttokentype $tokentype" |
|
#set result [::tomlish::parse::goNextState $nexttokentype $tokentype] |
|
::tomlish::log::debug "--->> zeropoppushspace goNextState REENTRANCY. calling goNextState $nexttokentype $currentstate" |
|
set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] |
|
set result [dict get $transition_info newstate] |
|
} |
|
PUSHSPACE { |
|
set original_target [dict get $transition_to PUSHSPACE] |
|
if {[dict exists $transition_to returnstate]} { |
|
#adjust the existing space record on the stack. |
|
#struct::stack doesn't really support that - so we have to pop and re-push |
|
#todo - investigate a custom stack implementation where we can efficiently lset the top of the stack |
|
set currentspace [spacestack pop] |
|
dict set currentspace returnstate [dict get $transition_to returnstate] |
|
spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. |
|
} |
|
if {[dict exists $transition_to starttok]} { |
|
set starttok [dict get $transition_to starttok] |
|
} |
|
spacestack push [dict create type space state $original_target] |
|
|
|
set last_space_action "push" |
|
set last_space_type "space" |
|
|
|
if {[dict exists $transition_to state]} { |
|
#an explicit state in the pushed space was requested in the stateMatrix - override the spacePushTransition (spacePushTransitions can be deprecated if we require explicitness?) |
|
set next [dict get $transition_to state] |
|
::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next by explicit 'state' entry" |
|
} else { |
|
#puts $::tomlish::parse::spacePushTransitions |
|
if {[dict exists $::tomlish::parse::spacePushTransitions $original_target]} { |
|
set next [dict get $::tomlish::parse::spacePushTransitions $original_target] |
|
::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next (spacePushTransitions) " |
|
} else { |
|
set next $original_target |
|
::tomlish::log::info "--->> PUSHSPACE transition to space $original_target" |
|
} |
|
} |
|
set result $next |
|
} |
|
TOSTATE { |
|
if {[dict exists $transition_to returnstate]} { |
|
#adjust the existing space record on the stack. |
|
#struct::stack doesn't really support that - so we have to pop and re-push |
|
#todo - investigate a custom stack implementation where we can efficiently lset the top of the stack |
|
set currentspace [spacestack pop] |
|
dict set currentspace returnstate [dict get $transition_to returnstate] |
|
spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. |
|
} |
|
set result [dict get $transition_to TOSTATE] |
|
} |
|
default { |
|
#simplified version of TOSTATE |
|
set result [lindex $transition_to 0] ;#ignore everything but first word |
|
} |
|
} |
|
} else { |
|
::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" |
|
set result "nostate" |
|
} |
|
lappend state_list [list tokentype $tokentype from $currentstate to $result] |
|
set state $result |
|
::tomlish::log::notice "--->> STATE TRANSITION tokenType: '$tokentype' tok:$tok triggering '$currentstate' -> '$result' last_space_action:$last_space_action " |
|
return [dict create prevstate $prevstate newstate $result space_action $last_space_action starttok $starttok] |
|
} |
|
|
|
proc report_line {{line ""}} { |
|
variable linenum |
|
variable is_parsing |
|
if {$is_parsing} { |
|
if {$line eq ""} { |
|
set line $linenum |
|
} |
|
return "Line Number: $line" |
|
} else { |
|
#not in the middle of parsing tomlish text - return nothing. |
|
return "" |
|
} |
|
} |
|
|
|
#produce a *slightly* more readable string rep of the nest for puts etc. |
|
proc nest_pretty1 {list} { |
|
set prettier "{" |
|
|
|
foreach el $list { |
|
if { [lindex $el 0] eq "NEWLINE"} { |
|
append prettier "[list $el]\n" |
|
} elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY QKEY SQKEY TABLE ARRAY})} { |
|
append prettier [nest_pretty1 $el] |
|
} else { |
|
append prettier "[list $el] " |
|
} |
|
} |
|
append prettier "}" |
|
return $prettier |
|
} |
|
|
|
proc set_tokenType {t} { |
|
variable tokenType |
|
variable tokenType_list |
|
if {![info exists tokenType]} { |
|
set tokenType "" |
|
} |
|
lappend tokenType_list $t |
|
set tokenType $t |
|
} |
|
|
|
proc switch_tokenType {t} { |
|
variable tokenType |
|
variable tokenType_list |
|
lset tokenType_list end $t |
|
set tokenType $t |
|
} |
|
|
|
proc get_tokenType {} { |
|
variable tokenType |
|
return $tokenType |
|
} |
|
|
|
proc _shortcircuit_startquotesequence {} { |
|
variable tok |
|
variable i |
|
set toklen [tcl::string::length $tok] |
|
if {$toklen == 1} { |
|
set_tokenType "startquote" |
|
incr i -1 |
|
return -level 2 1 |
|
} elseif {$toklen == 2} { |
|
puts stderr "_shortcircuit_startquotesequence toklen 2" |
|
set_tokenType "startquote" |
|
set tok "\"" |
|
incr i -2 |
|
return -level 2 1 |
|
} |
|
} |
|
|
|
proc get_token_waiting {} { |
|
variable token_waiting |
|
return [lindex $token_waiting 0] |
|
} |
|
proc clear_token_waiting {} { |
|
variable token_waiting |
|
set token_waiting [list] |
|
} |
|
|
|
#token_waiting is a list - but our standard case is to have only one |
|
#in certain circumstances such as near eof we may have 2 |
|
#the set_token_waiting function only allows setting when there is not already one waiting. |
|
#we want to catch cases of inadvertently trying to set multiple |
|
# - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. |
|
proc set_token_waiting {args} { |
|
if {[llength $args] %2 != 0} { |
|
error "tomlish set_token_waiting must have args of form: type <tokentype> value <value> complete 0|1" |
|
} |
|
variable token_waiting |
|
|
|
if {[llength $token_waiting] && [dict get [lindex $token_waiting end] type] ne "eof"} { |
|
#tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another |
|
#we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context |
|
#rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it |
|
set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" |
|
append err \n " - cannot add token_waiting: $args" |
|
error $err |
|
#set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] |
|
#set token_waiting [list] |
|
} |
|
|
|
set waiting [dict create] |
|
dict for {k v} $args { |
|
switch -exact $k { |
|
type - complete { |
|
dict set waiting $k $v |
|
} |
|
value { |
|
dict set waiting tok $v |
|
} |
|
startindex { |
|
dict set waiting startindex $v |
|
} |
|
default { |
|
error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" |
|
} |
|
} |
|
} |
|
if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { |
|
error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" |
|
} |
|
if {![llength $token_waiting]} { |
|
set token_waiting [list $waiting] |
|
} else { |
|
#an extra sanity-check that we don't have more than just the eof.. |
|
if {[llength $token_waiting] > 1} { |
|
set err "tomlish Unexpected. Existing token_waiting count > 1.\n" |
|
foreach tw $token_waiting { |
|
append err " $tw" \n |
|
} |
|
append err " - cannot add token_waiting: $waiting" |
|
error $err |
|
} |
|
#last entry must be a waiting eof |
|
set token_waiting [list $waiting [lindex $token_waiting end]] |
|
} |
|
return |
|
} |
|
|
|
#returns 0 or 1 |
|
#tomlish::parse::tok |
|
#we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag |
|
# - the possible benefit is being able to more easily process in arbitrarily split chunks (although we would still have to watch crlf splitting ?) |
|
# - interactive use? |
|
|
|
proc tok {s} { |
|
variable nest |
|
variable v |
|
variable i |
|
variable tok |
|
variable type ;#character type |
|
variable state ;#FSM |
|
|
|
|
|
variable tokenType |
|
variable tokenType_list |
|
|
|
|
|
variable endToken |
|
|
|
variable lastChar |
|
|
|
variable braceCount |
|
variable bracketCount |
|
|
|
|
|
#------------------------------ |
|
#Previous run found another (presumably single-char) token |
|
#The normal case is for there to be only one dict in the list |
|
#multiple is an exception - primarily for eof |
|
variable token_waiting |
|
if {[llength $token_waiting]} { |
|
set waiting [lindex $token_waiting 0] |
|
|
|
set tokenType [dict get $waiting type] |
|
set tok [dict get $waiting tok] |
|
#todo: dict get $token_waiting complete |
|
set token_waiting [lrange $token_waiting 1 end] |
|
return 1 |
|
} |
|
#------------------------------ |
|
|
|
set resultlist [list] |
|
set sLen [tcl::string::length $s] |
|
|
|
set slash_active 0 |
|
set quote 0 |
|
set c "" |
|
set multi_dquote "" |
|
for {} {$i < $sLen} {} { |
|
if {$i > 0} { |
|
set lastChar [tcl::string::index $s [expr {$i - 1}]] |
|
} else { |
|
set lastChar "" |
|
} |
|
|
|
set c [tcl::string::index $s $i] |
|
set cindex $i |
|
tomlish::log::debug "- tokloop char <$c> index $i tokenType:$tokenType tok:<$tok>" |
|
#puts "got char $c during tokenType '$tokenType'" |
|
incr i ;#must incr here because we do returns inside the loop |
|
|
|
set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] |
|
switch -exact -- $ctest { |
|
# { |
|
set dquotes $multi_dquote |
|
set multi_dquote "" |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
|
|
if {$had_slash} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. |
|
|
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
barekey { |
|
error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" |
|
} |
|
whitespace { |
|
# hash marks end of whitespace token |
|
#do a return for the whitespace, set token_waiting |
|
#set_token_waiting type comment value "" complete 1 |
|
incr i -1 ;#leave comment for next run |
|
return 1 |
|
} |
|
untyped_value { |
|
#REVIEW! the spec isn't clear.. is whitespace after an int,bool etc required before comment? |
|
#we will accept a comment marker as an immediate terminator of the untyped_value. |
|
incr i -1 |
|
return 1 |
|
} |
|
starttablename - starttablearrayname { |
|
#fix! |
|
error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" |
|
} |
|
tablename - tablearrayname { |
|
#invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out |
|
append tok $c |
|
} |
|
default { |
|
#quotedkey, itablequotedkey, string,literal, multistring |
|
append tok $c |
|
} |
|
} |
|
} else { |
|
switch -- $state { |
|
multistring-space { |
|
set_tokenType stringpart |
|
set tok "" |
|
if {$had_slash} { |
|
append tok "\\" |
|
} |
|
append tok "$dquotes#" |
|
} |
|
multiliteral-space { |
|
set_tokenType "literalpart" |
|
set tok "#" |
|
} |
|
default { |
|
#start of token if we're not in a token |
|
set_tokenType comment |
|
set tok "" ;#The hash is not part of the comment data |
|
} |
|
} |
|
} |
|
} |
|
lc { |
|
#left curly brace |
|
set dquotes $multi_dquote |
|
set multi_dquote "" |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
|
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
literal - literalpart - squotedkey - itablesquotedkey { |
|
append tok $c |
|
} |
|
string - quotedkey - itablequotedkey { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
stringpart { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $dquotes$c |
|
} |
|
starttablename - starttablearrayname { |
|
#*bare* tablename can only contain letters,digits underscores |
|
error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" |
|
} |
|
tablename - tablearrayname { |
|
#valid in quoted parts |
|
append tok $c |
|
} |
|
comment { |
|
if {$had_slash} {append tok "\\"} |
|
append tok "\[" |
|
} |
|
default { |
|
#end any other token. |
|
incr i -1 |
|
return 1 |
|
} |
|
} |
|
} else { |
|
switch -exact -- $state { |
|
itable-keyval-value-expected - keyval-value-expected - value-expected { |
|
#switch last key to tablename?? |
|
set_tokenType "startinlinetable" |
|
set tok "\{" |
|
return 1 |
|
} |
|
array-space - array-syntax { |
|
#nested anonymous inline table |
|
set_tokenType "startinlinetable" |
|
set tok "\{" |
|
return 1 |
|
} |
|
table-space { |
|
#invalid - but allow parser statemachine to report it. ? |
|
set_tokenType "startinlinetable" |
|
set tok "\{" |
|
return 1 |
|
} |
|
multistring-space { |
|
set_tokenType "stringpart" |
|
set tok "" |
|
if {$had_slash} { |
|
append tok "\\" |
|
} |
|
append tok "$dquotes\{" |
|
} |
|
multiliteral-space { |
|
set_tokenType "literalpart" |
|
set tok "\{" |
|
} |
|
default { |
|
error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" |
|
} |
|
} |
|
} |
|
|
|
} |
|
rc { |
|
#right curly brace |
|
set dquotes $multi_dquote |
|
set multi_dquote "" |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
|
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
literal - literalpart - squotedkey - itablesquotedkey { |
|
append tok $c |
|
} |
|
string - quotedkey - itablequotedkey - comment { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
stringpart { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $dquotes$c |
|
} |
|
starttablename - tablename { |
|
if {$had_slash} {append tok "\\"} |
|
#invalid! - but leave for datastructure loading stage to catch |
|
set_token_waiting type endinlinetable value "" complete 1 startindex $cindex |
|
return 1 |
|
} |
|
starttablearrayname - tablearrayname { |
|
if {$had_slash} {append tok "\\"} |
|
#invalid! - but leave for datastructure loading stage to catch |
|
set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex |
|
return 1 |
|
} |
|
itable-val-tail { |
|
#review |
|
error "tomlish right-curly in itable-val-tail" |
|
} |
|
default { |
|
#end any other token |
|
incr i -1 |
|
return 1 |
|
} |
|
} |
|
} else { |
|
#$slash_active not relevant when no tokenType |
|
switch -exact -- $state { |
|
value-expected { |
|
#invalid - but allow parser statemachine to report it. |
|
set_tokenType "endinlinetable" |
|
set tok "\}" |
|
return 1 |
|
} |
|
table-space { |
|
#invalid - but allow parser statemachine to report it. ? |
|
set_tokenType "endinlinetable" |
|
set tok "\}" |
|
return 1 |
|
} |
|
itable-space { |
|
set_tokenType "endinlinetable" |
|
set tok "\}" |
|
return 1 |
|
} |
|
tablename-state { |
|
#e.g [] - empty tablename - allowed or not? |
|
#empty tablename/tablearrayname ? |
|
#error "unexpected tablename problem" |
|
|
|
set_tokenType "endinlinetable" |
|
set tok "" ;#no output into the tomlish list for this token |
|
return 1 |
|
} |
|
tablearrayname-state { |
|
error "tomlish unexpected tablearrayname-state problem" |
|
set_tokenType "endinlinetable" |
|
set tok "" ;#no output into the tomlish list for this token |
|
return 1 |
|
} |
|
array-syntax - array-space { |
|
#invalid |
|
set_tokenType "endinlinetable" |
|
set tok "\}" |
|
return 1 |
|
} |
|
curly-syntax { |
|
set_tokenType "endinlinetable" |
|
set tok "\}" |
|
return 1 |
|
} |
|
itable-val-tail { |
|
set_tokenType "endinlinetable" |
|
set tok "" |
|
#we need to pop the keyval - and then reprocess to pop the inlinetable - so we incr -1 |
|
incr i -1 |
|
return 1 |
|
} |
|
itable-keyval-syntax { |
|
error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" |
|
} |
|
multistring-space { |
|
set_tokenType "stringpart" |
|
set tok "" |
|
if {$had_slash} { |
|
append tok "\\" |
|
} |
|
append tok "$dquotes\}" |
|
} |
|
multiliteral-space { |
|
set_tokenType "literalpart" ; #review |
|
set tok "\}" |
|
} |
|
default { |
|
#JMN2024b keyval-tail? |
|
error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" |
|
} |
|
} |
|
} |
|
|
|
} |
|
lb { |
|
#left square bracket |
|
set dquotes $multi_dquote |
|
set multi_dquote "" |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
|
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
literal - literalpart - squotedkey - itablesquotedkey { |
|
append tok $c |
|
} |
|
string - quotedkey - itablequotedkey { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
stringpart { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $dquotes$c |
|
} |
|
starttablename { |
|
#change the tokenType |
|
switch_tokenType "starttablearrayname" |
|
set tok "" ;#no output into the tomlish list for this token |
|
#any following whitespace is part of the tablearrayname, so return now |
|
return 1 |
|
} |
|
tablename { |
|
#e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token |
|
if {$had_slash} { |
|
#resultant tablename may be invalid - but leave for datastructure loading stage to catch |
|
append tok "\\[" |
|
} else { |
|
if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { |
|
#invalid at this point - state machine should disallow table -> starttablearrayname |
|
set_token_waiting type starttablearrayname value "" complete 1 startindex $cindex |
|
return 1 |
|
} else { |
|
#we appear to still be in single or double quoted section |
|
append tok "\[" |
|
} |
|
} |
|
} |
|
comment { |
|
if {$had_slash} {append tok "\\"} |
|
append tok "\[" |
|
} |
|
default { |
|
#end any other token. |
|
incr i -1 |
|
return 1 |
|
} |
|
} |
|
} else { |
|
#$slash_active not relevant when no tokenType |
|
switch -exact -- $state { |
|
keyval-value-expected - itable-keyval-value-expected - value-expected { |
|
set_tokenType "startarray" |
|
set tok "\[" |
|
return 1 |
|
} |
|
table-space { |
|
#table name |
|
#assume it's a single bracket - but we need to wait for non-bracket to confirm it's not a tablearray |
|
#note that a starttablearrayname token may contain whitespace between the brackets |
|
# e.g \[ \[ |
|
set_tokenType "starttablename" |
|
set tok "" ;#there is no output into the tomlish list for this token |
|
} |
|
array-space - array-syntax { |
|
#nested array? |
|
set_tokenType "startarray" |
|
set tok "\[" |
|
return 1 |
|
#error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" |
|
} |
|
multistring-space { |
|
set_tokenType "stringpart" |
|
set tok "" |
|
if {$had_slash} { |
|
append tok "\\" |
|
} |
|
append tok "$dquotes\[" |
|
} |
|
multiliteral-space { |
|
set_tokenType "literalpart" |
|
set tok "\[" |
|
} |
|
itable-space { |
|
#handle state just to give specific error msg |
|
error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[<vals>\] syntax. [tomlish::parse::report_line]" |
|
} |
|
default { |
|
error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" |
|
} |
|
} |
|
} |
|
} |
|
rb { |
|
#right square bracket |
|
set dquotes $multi_dquote |
|
set multi_dquote "" |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
|
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
literal - literalpart - squotedkey - itablesquotedkey { |
|
append tok $c |
|
} |
|
string - quotedkey - itablequotedkey { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
stringpart { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $dquotes$c |
|
} |
|
comment { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
whitespace { |
|
if {$state eq "multistring-space"} { |
|
#???? |
|
incr i -1 |
|
if {$had_slash} {incr i -1} ;#reprocess |
|
return 1 |
|
} else { |
|
incr i -1 |
|
if {$had_slash} {incr i -1} ;#reprocess |
|
return 1 |
|
} |
|
} |
|
tablename { |
|
#e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token |
|
if {$had_slash} { |
|
#resultant tablename may be invalid - but leave for datastructure loading stage to catch |
|
append tok "\\]" |
|
} else { |
|
if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { |
|
set_token_waiting type endtablename value "" complete 1 startindex $cindex |
|
return 1 |
|
} else { |
|
#we appear to still be in single or double quoted section |
|
append tok "]" |
|
} |
|
} |
|
} |
|
tablearraynames { |
|
#todo? |
|
if {$had_slash} {append tok "\\"} |
|
#invalid! - but leave for datastructure loading stage to catch |
|
set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex |
|
return 1 |
|
} |
|
default { |
|
incr i -1 |
|
return 1 |
|
} |
|
} |
|
} else { |
|
#$slash_active not relevant when no tokenType |
|
switch -exact -- $state { |
|
value-expected { |
|
#invalid - but allow parser statemachine to report it. |
|
set_tokenType "endarray" |
|
set tok "\]" |
|
return 1 |
|
} |
|
table-space { |
|
#invalid - but allow parser statemachine to report it. ? |
|
set_tokenType "endarray" |
|
set tok "\]" |
|
return 1 |
|
} |
|
tablename-state { |
|
#e.g [] - empty tablename - allowed or not? |
|
#empty tablename/tablearrayname ? |
|
#error "unexpected tablename problem" |
|
|
|
set_tokenType "endtablename" |
|
set tok "" ;#no output into the tomlish list for this token |
|
return 1 |
|
} |
|
tablearrayname-state { |
|
error "tomlish unexpected tablearrayname problem" |
|
set_tokenType "endtablearray" |
|
set tok "" ;#no output into the tomlish list for this token |
|
return 1 |
|
} |
|
array-syntax - array-space { |
|
set_tokenType "endarray" |
|
set tok "\]" |
|
return 1 |
|
} |
|
multistring-space { |
|
set_tokenType "stringpart" |
|
set tok "" |
|
if {$had_slash} { |
|
append tok "\\" |
|
} |
|
append tok "$dquotes\]" |
|
} |
|
multiliteral-space { |
|
set_tokenType "literalpart" |
|
set tok "\]" |
|
} |
|
default { |
|
error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" |
|
} |
|
} |
|
} |
|
} |
|
bsl { |
|
set dquotes $multi_dquote |
|
set multi_dquote "" ;#!! |
|
#backslash |
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
whitespace { |
|
if {$state eq "multistring-space"} { |
|
#end whitespace token |
|
incr i -1 ;#reprocess bsl in next run |
|
return 1 |
|
} else { |
|
error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" |
|
} |
|
} |
|
literal - literalpart - squotedkey - itablesquotedkey { |
|
#never need to set slash_active true when in single quoted tokens |
|
append tok "\\" |
|
set slash_active 0 |
|
} |
|
string - quotedkey - itablequotedkey - comment { |
|
if {$slash_active} { |
|
set slash_active 0 |
|
append tok "\\\\" |
|
} else { |
|
set slash_active 1 |
|
} |
|
} |
|
stringpart { |
|
if {$slash_active} { |
|
#assert - quotes empty - or we wouldn't have slash_active |
|
set slash_active 0 |
|
append tok "\\\\" |
|
} else { |
|
append tok $dquotes |
|
set slash_active 1 |
|
} |
|
} |
|
starttablename - starttablearrayname { |
|
error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" |
|
} |
|
tablename - tablearrayname { |
|
if {$slash_active} { |
|
set slash_active 0 |
|
append tok "\\\\" |
|
} else { |
|
set slash_active 1 |
|
} |
|
} |
|
barekey { |
|
error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" |
|
} |
|
default { |
|
error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" |
|
} |
|
} |
|
} else { |
|
switch -exact -- $state { |
|
multistring-space { |
|
if {$slash_active} { |
|
set_tokenType "stringpart" |
|
set tok "\\\\" |
|
set slash_active 0 |
|
} else { |
|
if {$dquotes ne ""} { |
|
set_tokenType "stringpart" |
|
set tok $dquotes |
|
} |
|
set slash_active 1 |
|
} |
|
} |
|
multiliteral-space { |
|
#nothing can be escaped in multiliteral-space - not even squotes (?) review |
|
set_tokenType "literalpart" |
|
set tok "\\" |
|
} |
|
default { |
|
error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" |
|
} |
|
} |
|
} |
|
} |
|
sq { |
|
#single quote |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
squote_seq { |
|
#short squote_seq tokens are returned if active during any other character |
|
#longest allowable for leading/trailing are returned here |
|
#### |
|
set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote |
|
switch -- $state { |
|
leading-squote-space { |
|
append tok $c |
|
if {$existingtoklen > 2} { |
|
error "tomlish tok error: squote_seq unexpected length $existingtoklen when another received" |
|
} elseif {$existingtoklen == 2} { |
|
return 1 ;#return tok ''' |
|
} |
|
} |
|
trailing-squote-space { |
|
append tok $c |
|
if {$existingtoklen == 4} { |
|
#maxlen to be an squote_seq is multisquote + 2 = 5 |
|
#return tok ''''' |
|
return 1 |
|
} |
|
} |
|
default { |
|
error "tomlish tok error: squote_seq in unexpected state '$state' - expected leading-squote-space or trailing-squote-space" |
|
} |
|
} |
|
} |
|
whitespace { |
|
#end whitespace |
|
incr i -1 ;#reprocess sq |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
#temp token creatable only during value-expected or array-space |
|
switch -- [tcl::string::length $tok] { |
|
1 { |
|
append tok $c |
|
} |
|
2 { |
|
#switch? |
|
append tok $c |
|
set_tokenType triple_squote |
|
return 1 |
|
} |
|
default { |
|
error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" |
|
} |
|
} |
|
} |
|
literal { |
|
#slash_active always false |
|
#terminate the literal |
|
set_token_waiting type endsquote value "'" complete 1 startindex $cindex |
|
return 1 |
|
} |
|
literalpart { |
|
#ended by ''' - but final could be '''' or ''''' (up to 2 squotes allowed directly before ending triple squote sequence) |
|
#todo |
|
# idea: end this literalpart (possibly 'temporarily') |
|
# let the sq be reprocessed in the multiliteral-space to push an end-multiliteral-sequence to state stack |
|
# upon popping end-multiliteral-sequence - stitch quotes back into this literalpart's token (if either too short - or a long ending sequence as shown above) |
|
incr i -1 ;#throw the "'" back to loop - will be added to an squote_seq token for later processing |
|
return 1 |
|
} |
|
itablesquotedkey { |
|
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 |
|
} |
|
default { |
|
append tok $c |
|
} |
|
} |
|
} else { |
|
switch -exact -- $state { |
|
value-expected - array-space { |
|
set_tokenType "_start_squote_sequence" |
|
set tok "'" |
|
} |
|
itable-keyval-value-expected - keyval-value-expected { |
|
set_tokenType "squote_seq_begin" |
|
set tok "'" |
|
return 1 |
|
} |
|
table-space { |
|
### |
|
set_tokenType "squotedkey" |
|
set tok "" |
|
} |
|
itable-space { |
|
set_tokenType "squote_seq_begin" |
|
set tok "'" |
|
return 1 |
|
} |
|
tablename-state { |
|
#first char in tablename-state/tablearrayname-state |
|
set_tokenType tablename |
|
append tok "'" |
|
} |
|
tablearrayname-state { |
|
set_tokenType tablearrayname |
|
append tok "'" |
|
} |
|
literal-state { |
|
tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?" |
|
set_tokenType literal |
|
incr -1 |
|
return 1 |
|
} |
|
multistring-space { |
|
error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" |
|
} |
|
multiliteral-space { |
|
#each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row |
|
#we are building up an squote_seq to determine if |
|
#a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines |
|
#b) it is exactly ''' and we can terminate the whole multiliteral |
|
#c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space |
|
set_tokenType "squote_seq_begin" |
|
set tok "'" |
|
return 1 |
|
} |
|
dottedkey-space { |
|
set_tokenType squotedkey |
|
} |
|
default { |
|
error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" |
|
} |
|
} |
|
} |
|
|
|
} |
|
dq { |
|
#double quote |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
|
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
set toklen [tcl::string::length $tok] |
|
if {$toklen == 1} { |
|
append tok $c |
|
} elseif {$toklen == 2} { |
|
append tok $c |
|
#switch vs set? |
|
set_tokenType "startmultiquote" |
|
return 1 |
|
} else { |
|
error "tomlish unexpected token length $toklen in 'startquotesequence'" |
|
} |
|
} |
|
_start_squote_sequence { |
|
set toklen [tcl::string::length $tok] |
|
switch -- $toklen { |
|
1 { |
|
set_tokenType "startsquote" |
|
incr i -1 |
|
return 1 |
|
} |
|
2 { |
|
set_tokenType "startsquote" |
|
incr i -2 |
|
return 1 |
|
} |
|
default { |
|
error "tomlish unexpected _start_squote_sequence length $toklen" |
|
} |
|
} |
|
} |
|
literal - literalpart { |
|
append tok $c |
|
} |
|
string { |
|
if {$had_slash} { |
|
append tok "\\" $c |
|
} else { |
|
#unescaped quote always terminates a string? |
|
set_token_waiting type endquote value "\"" complete 1 startindex $cindex |
|
return 1 |
|
} |
|
} |
|
stringpart { |
|
#sub element of multistring |
|
if {$had_slash} { |
|
append tok "\\" $c |
|
} else { |
|
#incr i -1 |
|
|
|
if {$multi_dquote eq "\"\""} { |
|
set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex -2}] |
|
set multi_dquote "" |
|
return 1 |
|
} else { |
|
append multi_dquote "\"" |
|
} |
|
} |
|
} |
|
whitespace { |
|
switch -exact -- $state { |
|
multistring-space { |
|
#REVIEW |
|
if {$had_slash} { |
|
incr i -2 |
|
return 1 |
|
} else { |
|
switch -- [tcl::string::length $multi_dquote] { |
|
2 { |
|
set_token_waiting type endmultiquote value "\"\"\"" complete 1 startindex [expr {$cindex-2}] |
|
set multi_dquote "" |
|
return 1 |
|
} |
|
1 { |
|
incr i -2 |
|
return 1 |
|
} |
|
0 { |
|
incr i -1 |
|
return 1 |
|
} |
|
} |
|
} |
|
} |
|
keyval-value-expected - value-expected { |
|
#end whitespace token and reprocess |
|
incr i -1 |
|
return 1 |
|
|
|
#if {$multi_dquote eq "\"\""} { |
|
# set_token_waiting type startmultiquote value "\"\"\"" complete 1 |
|
# set multi_dquote "" |
|
# return 1 |
|
#} else { |
|
# #end whitespace token and reprocess |
|
# incr i -1 |
|
# return 1 |
|
#} |
|
} |
|
default { |
|
set_token_waiting type startquote value "\"" complete 1 startindex $cindex |
|
return 1 |
|
} |
|
} |
|
} |
|
comment { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
quotedkey - itablequotedkey { |
|
if {$had_slash} { |
|
append tok "\\" |
|
append tok $c |
|
} else { |
|
set_token_waiting type endquote value "\"" complete 1 startindex $cindex |
|
return 1 |
|
} |
|
} |
|
squotedkey - itablesquotedkey { |
|
append tok $c |
|
} |
|
tablename - tablearrayname { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
starttablename - starttablearrayname { |
|
incr i -1 ;## |
|
return 1 |
|
} |
|
default { |
|
error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" |
|
} |
|
} |
|
} else { |
|
#$slash_active not relevant when no tokenType |
|
#token is string only if we're expecting a value at this point |
|
switch -exact -- $state { |
|
keyval-value-expected - value-expected - array-space { |
|
#!? start looking for possible multistartquote |
|
#set_tokenType startquote |
|
#set tok $c |
|
#return 1 |
|
set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote |
|
set tok $c |
|
} |
|
itable-keyval-value-expected { |
|
#JMN 2025 - review |
|
set_tokenType "startquotesequence" ;#one or more quotes in a row - either startquote or multistartquote |
|
set tok $c |
|
} |
|
multistring-space { |
|
#TODO - had_slash!!! |
|
#REVIEW |
|
if {$had_slash} { |
|
set_tokenType "stringpart" |
|
set tok "\\\"" |
|
set multi_dquote "" |
|
} else { |
|
if {$multi_dquote eq "\"\""} { |
|
tomlish::log::debug "- tokloop char dq ---> endmultiquote" |
|
set_tokenType "endmultiquote" |
|
set tok "\"\"\"" |
|
return 1 |
|
#set_token_waiting type endmultiquote value "\"\"\"" complete 1 |
|
#set multi_dquote "" |
|
#return 1 |
|
} else { |
|
append multi_dquote "\"" |
|
} |
|
} |
|
} |
|
multiliteral-space { |
|
set_tokenType "literalpart" |
|
set tok "\"" |
|
} |
|
table-space { |
|
set_tokenType "startquote" |
|
set tok $c |
|
return 1 |
|
} |
|
itable-space { |
|
set_tokenType "startquote" |
|
set tok $c |
|
return 1 |
|
} |
|
tablename-state { |
|
set_tokenType tablename |
|
set tok $c |
|
} |
|
tablearrayname-state { |
|
set_tokenType tablearrayname |
|
set tok $c |
|
} |
|
dottedkey-space { |
|
set_tokenType dquote_seq_begin |
|
set tok $c |
|
} |
|
default { |
|
error "tomlish Unexpected quote during state '$state' [tomlish::parse::report_line]" |
|
} |
|
} |
|
} |
|
} |
|
= { |
|
set dquotes $multi_dquote |
|
set multi_dquote "" ;#!! |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
|
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
literal - literalpart - squotedkey { |
|
#assertion had_slash 0, multi_dquote "" |
|
append tok $c |
|
} |
|
string - comment - quotedkey - itablequotedkey { |
|
#for these tokenTypes an = is just data. |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
stringpart { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $dquotes$c |
|
} |
|
whitespace { |
|
if {$state eq "multistring-space"} { |
|
set backlen [expr {[tcl::string::length $dquotes] + 1}] |
|
incr i -$backlen |
|
return 1 |
|
} else { |
|
set_token_waiting type equal value = complete 1 startindex $cindex |
|
return 1 |
|
} |
|
} |
|
barekey { |
|
#set_token_waiting type equal value = complete 1 |
|
incr i -1 |
|
return 1 |
|
} |
|
starttablename - starttablearrayname { |
|
error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" |
|
} |
|
tablename - tablearrayname { |
|
#invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out |
|
append tok $c |
|
} |
|
default { |
|
error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" |
|
} |
|
} |
|
} else { |
|
switch -exact -- $state { |
|
multistring-space { |
|
set_tokenType "stringpart" |
|
set tok "" |
|
if {$had_slash} { |
|
append tok "\\" |
|
} |
|
append tok ${dquotes}= |
|
} |
|
multiliteral-space { |
|
set_tokenType "literalpart" |
|
set tok "=" |
|
} |
|
dottedkey-space { |
|
set_tokenType "equal" |
|
set tok "=" |
|
return 1 |
|
} |
|
default { |
|
set_tokenType "equal" |
|
set tok = |
|
return 1 |
|
} |
|
} |
|
} |
|
} |
|
cr { |
|
#REVIEW! |
|
set dquotes $multi_dquote |
|
set multi_dquote "" ;#!! |
|
# \r carriage return |
|
if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. |
|
set slash_active 0 |
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
literal { |
|
append tok $c |
|
} |
|
literalpart { |
|
#part of MLL string (multi-line literal string) |
|
#we need to split out crlf as a separate NEWLINE to be consistent |
|
::tomlish::log::warn "literalpart ended by cr - needs testing" |
|
#return literalpart temporarily - allow cr to be reprocessed from multiliteral-space |
|
incr i -1 |
|
return 1 |
|
} |
|
stringpart { |
|
#part of MLB string (multi-line basic string) |
|
#jmn2025 - review |
|
#append tok $dquotes$c |
|
incr i -1 |
|
return 1 |
|
} |
|
starttablename - starttablearrayname { |
|
error "tomlish Character <carriage return> is invalid first character for $tokenType. [tomlish::parse::report_line]" |
|
} |
|
tablename - tablearrayname { |
|
#could in theory be valid in quoted part of name |
|
#review - might be better just to disallow here |
|
append tok $c |
|
} |
|
default { |
|
#!todo - error out if cr inappropriate for tokenType |
|
append tok $c |
|
} |
|
} |
|
} else { |
|
#lf may be appended if next |
|
#review - lone cr as newline? - this is uncommon - but so is lone cr in a string(?) |
|
set_tokenType "newline" |
|
set tok cr |
|
} |
|
} |
|
lf { |
|
# \n newline |
|
set dquotes $multi_dquote |
|
set multi_dquote "" ;#!! |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
literal { |
|
#nl is not allowed *within* a literal - require multiliteral syntax for any literal containing a newline ''' ''' |
|
#even though we terminate the literal without the closing quote here - the token_waiting newline should trigger a state error |
|
set_token_waiting type newline value lf complete 1 startindex $cindex |
|
return 1 |
|
} |
|
literalpart { |
|
#we allow newlines - but store them within the multiliteral as their own element |
|
#This is a legitimate end to the literalpart - but not the whole multiliteral |
|
set_token_waiting type newline value lf complete 1 startindex $cindex |
|
return 1 |
|
} |
|
newline { |
|
#review |
|
#this lf is the trailing part of a crlf |
|
append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok |
|
return 1 |
|
} |
|
stringpart { |
|
if {$dquotes ne ""} { |
|
append tok $dquotes |
|
incr i -1 |
|
return 1 |
|
} else { |
|
if {$had_slash} { |
|
#emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) |
|
set_token_waiting type continuation value \\ complete 1 startindex [expr {$cindex-1}] |
|
incr i -1 |
|
return 1 |
|
} else { |
|
set_token_waiting type newline value lf complete 1 startindex $cindex |
|
return 1 |
|
} |
|
} |
|
} |
|
starttablename - tablename - tablearrayname - starttablearrayname { |
|
error "tomlish Character <linefeed> is invalid in $tokenType. [tomlish::parse::report_line]" |
|
} |
|
default { |
|
#newline ends all other tokens. |
|
#note for string: we don't add (raw unescaped) newline to simple string. (must use multi-string for this) |
|
#note for whitespace: |
|
# we will use the convention that \n terminates the current whitespace even if whitespace follows |
|
# ie whitespace is split into separate whitespace tokens at each newline |
|
|
|
#puts "-------------- newline lf during tokenType $tokenType" |
|
set_token_waiting type newline value lf complete 1 startindex $cindex |
|
return 1 |
|
} |
|
} |
|
} else { |
|
switch -exact -- $state { |
|
multistring-space { |
|
if {$had_slash} { |
|
set_tokenType "continuation" |
|
set tok "\\" |
|
incr i -1 |
|
return 1 |
|
} else { |
|
if {$dquotes ne ""} { |
|
#e.g one or 2 quotes just before nl |
|
set_tokenType "stringpart" |
|
set tok $dquotes |
|
incr i -1 |
|
return 1 |
|
} |
|
set_tokenType "newline" |
|
set tok lf |
|
return 1 |
|
} |
|
} |
|
multiliteral-space { |
|
#assert had_slash 0, multi_dquote "" |
|
set_tokenType "newline" |
|
set tok "lf" |
|
return 1 |
|
} |
|
default { |
|
#ignore slash? error? |
|
set_tokenType "newline" |
|
set tok lf |
|
return 1 |
|
} |
|
} |
|
#if {$had_slash} { |
|
# #CONT directly before newline - allows strings_5_byteequivalent test to pass |
|
# set_tokenType "continuation" |
|
# set tok "\\" |
|
# incr i -1 |
|
# return 1 |
|
#} else { |
|
# set_tokenType newline |
|
# set tok lf |
|
# return 1 |
|
#} |
|
} |
|
} |
|
, { |
|
set dquotes $multi_dquote |
|
set multi_dquote "" |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
newline { |
|
#incomplete newline |
|
set_tokenType "cr" |
|
incr i -1 |
|
return 1 |
|
} |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
comment - tablename - tablearrayname { |
|
if {$had_slash} {append tok "\\"} |
|
append tok , |
|
} |
|
string - quotedkey - itablequotedkey { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
stringpart { |
|
#stringpart can have up to 2 quotes too |
|
if {$had_slash} {append tok "\\"} |
|
append tok $dquotes$c |
|
} |
|
literal - literalpart - squotedkey - itablesquotedkey { |
|
#assert had_slash always 0, multi_dquote "" |
|
append tok $c |
|
} |
|
whitespace { |
|
if {$state eq "multistring-space"} { |
|
set backlen [expr {[tcl::string::length $dquotes] + 1}] |
|
incr i -$backlen |
|
return 1 |
|
} else { |
|
set_token_waiting type comma value "," complete 1 startindex $cindex |
|
return 1 |
|
} |
|
} |
|
default { |
|
set_token_waiting type comma value "," complete 1 startindex $cindex |
|
if {$had_slash} {append tok "\\"} |
|
return 1 |
|
} |
|
} |
|
} else { |
|
switch -exact -- $state { |
|
multistring-space { |
|
set_tokenType "stringpart" |
|
set tok "" |
|
if {$had_slash} {append tok "\\"} |
|
append tok "$dquotes," |
|
} |
|
multiliteral-space { |
|
#assert had_slash 0, multi_dquote "" |
|
set_tokenType "literalpart" |
|
set tok "," |
|
} |
|
default { |
|
set_tokenType "comma" |
|
set tok "," |
|
return 1 |
|
} |
|
} |
|
} |
|
} |
|
. { |
|
set dquotes $multi_dquote |
|
set multi_dquote "" ;#!! |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
newline { |
|
#incomplete newline |
|
set_tokenType "cr" |
|
incr i -1 |
|
return 1 |
|
} |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
comment - untyped_value { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
string - quotedkey - itablequotedkey { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
stringpart { |
|
if {$had_slash} {append tok "\\"} |
|
append tok $dquotes$c |
|
} |
|
literal - literalpart - squotedkey - itablesquotedkey { |
|
#assert had_slash always 0, multi_dquote "" |
|
append tok $c |
|
} |
|
whitespace { |
|
switch -exact -- $state { |
|
multistring-space { |
|
set backchars [expr {[tcl::string::length $dquotes] + 1}] |
|
if {$had_slash} { |
|
incr backchars 1 |
|
} |
|
incr i -$backchars |
|
return 1 |
|
} |
|
dottedkey-space { |
|
incr i -1 |
|
return 1 |
|
} |
|
default { |
|
error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" |
|
} |
|
} |
|
} |
|
starttablename - starttablearrayname { |
|
#This would correspond to an empty table name |
|
error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" |
|
} |
|
tablename - tablearrayname { |
|
#subtable - split later - review |
|
append tok $c |
|
} |
|
barekey { |
|
#e.g x.y = 1 |
|
#we need to transition the barekey to become a structured table name ??? review |
|
#x is the tablename y is the key |
|
set_token_waiting type dotsep value "." complete 1 startindex $cindex |
|
return 1 |
|
} |
|
default { |
|
error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" |
|
#set_token_waiting type period value . complete 1 |
|
#return 1 |
|
} |
|
} |
|
} else { |
|
switch -exact -- $state { |
|
multistring-space { |
|
set_tokenType "stringpart" |
|
set tok "" |
|
if {$had_slash} {append tok "\\"} |
|
append tok "$dquotes." |
|
} |
|
multiliteral-space { |
|
set_tokenType "literalpart" |
|
set tok "." |
|
} |
|
dottedkey-space { |
|
### |
|
set_tokenType "dotsep" |
|
set tok "." |
|
return 1 |
|
} |
|
default { |
|
set_tokenType "untyped_value" |
|
set tok "." |
|
} |
|
} |
|
} |
|
|
|
} |
|
" " { |
|
set dquotes $multi_dquote |
|
set multi_dquote "" ;#!! |
|
if {[tcl::string::length $tokenType]} { |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
switch -exact -- $tokenType { |
|
newline { |
|
#incomplete newline |
|
set_tokenType "cr" |
|
incr i -1 |
|
return 1 |
|
} |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
barekey { |
|
#todo had_slash - emit token or error |
|
#whitespace is a terminator for bare keys |
|
#set_token_waiting type whitespace value $c complete 1 |
|
incr i -1 |
|
return 1 |
|
} |
|
untyped_value { |
|
#unquoted values (int,date,float etc) are terminated by whitespace |
|
#set_token_waiting type whitespace value $c complete 1 |
|
incr i -1 |
|
return 1 |
|
} |
|
comment { |
|
if {$had_slash} { |
|
append tok "\\" |
|
} |
|
append tok $dquotes$c |
|
} |
|
string - quotedkey - itablequotedkey { |
|
if {$had_slash} { append tok "\\" } |
|
append tok $c |
|
} |
|
stringpart { |
|
#for stringpart we store WS separately for ease of processing continuations (CONT stripping) |
|
if {$had_slash} { |
|
#REVIEW |
|
#emit the stringpart - go back to the slash |
|
incr i -2 |
|
return 1 |
|
} else { |
|
#split into STRINGPART aaa WS " " |
|
append tok $dquotes |
|
incr i -1 |
|
return 1 |
|
} |
|
} |
|
literal - literalpart - squotedkey - itablesquotedkey { |
|
append tok $c |
|
} |
|
whitespace { |
|
if {$state eq "multistring-space"} { |
|
if {$dquotes ne ""} { |
|
#end whitespace token |
|
#go back by the number of quotes plus this space char |
|
set backchars [expr {[tcl::string::length $dquotes] + 1}] |
|
incr i -$backchars |
|
return 1 |
|
} else { |
|
append tok $c |
|
} |
|
} else { |
|
append tok $c |
|
} |
|
} |
|
starttablename - starttablearrayname { |
|
incr i -1 |
|
return 1 |
|
} |
|
tablename - tablearrayname { |
|
#include whitespace in the tablename/tablearrayname |
|
#Will need to be normalized upon interpreting the tomlish as a datastructure |
|
append tok $c |
|
} |
|
default { |
|
error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" |
|
} |
|
} |
|
} else { |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
switch -exact -- $state { |
|
tablename-state { |
|
#tablename can have leading,trailing and interspersed whitespace! |
|
#These will not be treated as whitespace tokens, instead forming part of the name. |
|
set_tokenType tablename |
|
set tok "" |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
tablearrayname-state { |
|
set_tokenType tablearrayname |
|
set tok "" |
|
if {$had_slash} {append tok "\\"} |
|
append tok $c |
|
} |
|
multistring-space { |
|
if {$had_slash} { |
|
set_tokenType "continuation" |
|
set tok "\\" |
|
incr i -1 |
|
return 1 |
|
} else { |
|
if {$dquotes ne ""} { |
|
set_tokenType "stringpart" |
|
set tok $dquotes |
|
incr i -1 |
|
return 1 |
|
} |
|
set_tokenType "whitespace" |
|
append tok $c |
|
} |
|
} |
|
multiliteral-space { |
|
set_tokenType "literalpart" |
|
set tok $c |
|
} |
|
default { |
|
if {$had_slash} { |
|
error "tomlish unexpected backslash [tomlish::parse::report_line]" |
|
} |
|
set_tokenType "whitespace" |
|
append tok $c |
|
} |
|
} |
|
} |
|
} |
|
tab { |
|
set dquotes $multi_dquote |
|
set multi_dquote "" ;#!! |
|
|
|
if {[tcl::string::length $tokenType]} { |
|
if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out (?review) |
|
set slash_active 0 |
|
switch -exact -- $tokenType { |
|
newline { |
|
#incomplete newline |
|
set_tokenType "cr" |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
barekey { |
|
#whitespace is a terminator for bare keys |
|
incr i -1 |
|
#set_token_waiting type whitespace value $c complete 1 |
|
return 1 |
|
} |
|
untyped_value { |
|
#unquoted values (int,date,float etc) are terminated by whitespace |
|
#set_token_waiting type whitespace value $c complete 1 |
|
incr i -1 |
|
return 1 |
|
} |
|
quotedkey - itablequotedkey - squotedkey - itablesquotedkey { |
|
append tok $c |
|
} |
|
string - comment - whitespace { |
|
append tok $c |
|
} |
|
stringpart { |
|
#for stringpart we store WS separately for ease of processing continuations (CONT stripping) |
|
if {$had_slash} { |
|
#REVIEW |
|
#emit the stringpart - go back to the slash |
|
incr i -2 |
|
return 1 |
|
} else { |
|
#split into STRINGPART aaa WS " " |
|
append tok $dquotes |
|
incr i -1 |
|
return 1 |
|
} |
|
} |
|
literal - literalpart { |
|
append tok $c |
|
} |
|
starttablename - starttablearrayname { |
|
incr i -1 |
|
return 1 |
|
} |
|
tablename - tablearraynames { |
|
#include whitespace in the tablename/tablearrayname |
|
#Will need to be normalized upon interpreting the tomlish as a datastructure |
|
append tok $c |
|
} |
|
default { |
|
error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" |
|
} |
|
} |
|
} else { |
|
set had_slash $slash_active |
|
if {$slash_active} { |
|
set slash_active 0 |
|
} |
|
switch -exact -- $state { |
|
tablename-state { |
|
#tablename can have leading,trailing and interspersed whitespace! |
|
#These will not be treated as whitespace tokens, instead forming part of the name. |
|
set_tokenType tablename |
|
set tok $c |
|
} |
|
tablearrayname-state { |
|
set_tokenType tablearrayname |
|
set tok $c |
|
} |
|
multistring-space { |
|
if {$had_slash} { |
|
set_tokenType "continuation" |
|
set tok "\\" |
|
incr i -1 |
|
return 1 |
|
} else { |
|
if {$dquotes ne ""} { |
|
set_tokenType stringpart |
|
set tok $dquotes |
|
incr i -1 |
|
return 1 |
|
} else { |
|
set_tokenType whitespace |
|
append tok $c |
|
} |
|
} |
|
} |
|
multiliteral-space { |
|
set_tokenType "literalpart" |
|
set tok $c |
|
} |
|
default { |
|
set_tokenType "whitespace" |
|
append tok $c |
|
} |
|
} |
|
} |
|
} |
|
bom { |
|
#BOM (Byte Order Mark) - ignored by token consumer |
|
if {[tcl::string::length $tokenType]} { |
|
switch -exact -- $tokenType { |
|
_start_squote_sequence { |
|
#assert - tok will be one or two squotes only |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
literal - literalpart { |
|
append tok $c |
|
} |
|
default { |
|
set_token_waiting type bom value "\uFEFF" complete 1 startindex $cindex |
|
return 1 |
|
} |
|
} |
|
} else { |
|
switch -exact -- $state { |
|
multiliteral-space { |
|
set_tokenType "literalpart" |
|
set tok $c |
|
} |
|
default { |
|
set_tokenType "bom" |
|
set tok "\uFEFF" |
|
return 1 |
|
} |
|
} |
|
} |
|
} |
|
default { |
|
set dquotes $multi_dquote |
|
set multi_dquote "" ;#!! |
|
|
|
if {[tcl::string::length $tokenType]} { |
|
if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. |
|
set slash_active 0 |
|
switch -exact -- $tokenType { |
|
newline { |
|
#incomplete newline |
|
set_tokenType "cr" |
|
incr i -1 |
|
return 1 |
|
} |
|
squote_seq { |
|
incr i -1 |
|
return 1 |
|
} |
|
startquotesequence { |
|
_shortcircuit_startquotesequence |
|
} |
|
_start_squote_sequence { |
|
incr i -[tcl::string::length $tok] |
|
set_tokenType "startsquote" |
|
return 1 |
|
} |
|
whitespace { |
|
if {$state eq "multistring-space"} { |
|
if {$dquotes ne ""} { |
|
set backlen [expr {[tcl::string::length $dquotes] + 1}] |
|
incr i -$backlen |
|
return 1 |
|
} else { |
|
incr i -1 |
|
return 1 |
|
} |
|
} else { |
|
#review |
|
incr i -1 ;#We don't have a full token to add to the token_waiting dict - so leave this char for next run. |
|
return 1 |
|
} |
|
} |
|
barekey { |
|
if {[tomlish::utils::is_barekey $c]} { |
|
append tok $c |
|
} else { |
|
error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" |
|
} |
|
} |
|
starttablename - starttablearrayname { |
|
incr i -1 |
|
#allow statemachine to set context for subsequent chars |
|
return 1 |
|
} |
|
stringpart { |
|
append tok $dquotes$c |
|
} |
|
default { |
|
#e.g comment/string/literal/literalpart/untyped_value/starttablename/starttablearrayname/tablename/tablearrayname |
|
append tok $c |
|
} |
|
} |
|
} else { |
|
set had_slash $slash_active |
|
set slash_active 0 |
|
switch -exact -- $state { |
|
table-space - itable-space { |
|
#if no currently active token - assume another key value pair |
|
if {[tomlish::utils::is_barekey $c]} { |
|
set_tokenType "barekey" |
|
append tok $c |
|
} else { |
|
error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" |
|
} |
|
} |
|
curly-syntax { |
|
puts stderr "curly-syntax - review" |
|
if {[tomlish::utils::is_barekey $c]} { |
|
set_tokenType "barekey" |
|
append tok $c |
|
} else { |
|
error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" |
|
} |
|
} |
|
multistring-space { |
|
set_tokenType "stringpart" |
|
if {$had_slash} { |
|
#assert - we don't get had_slash and dquotes at same time |
|
set tok \\$c |
|
} else { |
|
set tok $dquotes$c |
|
} |
|
} |
|
multiliteral-space { |
|
set_tokenType "literalpart" |
|
set tok $c |
|
} |
|
tablename-state { |
|
set_tokenType "tablename" |
|
set tok $c |
|
} |
|
tablearrayname-state { |
|
set_tokenType "tablearrayname" |
|
set tok $c |
|
} |
|
dottedkey-space { |
|
set_tokenType barekey |
|
set tok $c |
|
} |
|
default { |
|
tomlish::log::debug "- tokloop char '$c' setting to untyped_value while state:$state" |
|
set_tokenType "untyped_value" |
|
set tok $c |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
} |
|
|
|
#run out of characters (eof) |
|
if {[tcl::string::length $tokenType]} { |
|
#check for invalid ending tokens |
|
#if {$state eq "err-state"} { |
|
# error "Reached end of data whilst tokenType = '$tokenType'. INVALID" |
|
#} |
|
switch -exact -- $tokenType { |
|
startquotesequence { |
|
set toklen [tcl::string::length $tok] |
|
if {$toklen == 1} { |
|
#invalid |
|
#eof with open string |
|
error "tomlish eof reached without closing quote for string. [tomlish::parse::report_line]" |
|
} elseif {$toklen == 2} { |
|
#valid |
|
#we ended in a double quote, not actually a startquoteseqence - effectively an empty string |
|
switch_tokenType "startquote" |
|
incr i -1 |
|
#set_token_waiting type string value "" complete 1 |
|
return 1 |
|
} |
|
} |
|
_start_squote_sequence { |
|
set toklen [tcl::string::length $tok] |
|
switch -- $toklen { |
|
1 { |
|
#invalid eof with open literal |
|
error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" |
|
} |
|
2 { |
|
#review |
|
set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] |
|
set_tokenType "literal" |
|
set tok "" |
|
return 1 |
|
} |
|
} |
|
} |
|
} |
|
set_token_waiting type eof value eof complete 1 startindex $i ;#review |
|
return 1 |
|
} else { |
|
::tomlish::log::debug "- No current tokenType, ran out of characters, setting tokenType to 'eof' [tomlish::parse::report_line]" |
|
set tokenType "eof" |
|
set tok "eof" |
|
} |
|
return 0 |
|
} |
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace tomlish::parse ---}] |
|
} |
|
|
|
namespace eval tomlish::dict { |
|
namespace export {[a-z]*}; # Convention: export all lowercase |
|
namespace path [namespace parent] |
|
|
|
proc is_tomlish_typeval {d} { |
|
#designed to detect {type <tag> value <whatever>} e.g {type INT value 3}, {type STRING value "blah etc"} |
|
#as a sanity check we need to avoid mistaking user data that happens to match same form |
|
#consider x.y={type="spud",value="blah"} |
|
#The value of type will itself have already been converted to {type STRING value spud} ie never a single element. |
|
#check the length of the type as a quick way to see it's a tag - not something else masqerading. |
|
expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} |
|
} |
|
proc is_tomlish_typeval2 {d} { |
|
upvar ::tomlish::tags tags |
|
expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} |
|
} |
|
proc last_tomltype_posn {d} { |
|
set last_simple -1 |
|
set dictposn [expr {[dict size $d] -1}] |
|
foreach k [lreverse [dict keys $d]] { |
|
set dval [dict get $d $k] |
|
if {[is_tomlish_typeval $dval]} { |
|
set last_simple $dictposn |
|
break |
|
} |
|
incr dictposn -1 |
|
} |
|
return $last_simple |
|
} |
|
|
|
|
|
#review |
|
proc name_from_tablestack {tablestack} { |
|
set name "" |
|
foreach tinfo [lrange $tablestack 1 end] { |
|
lassign $tinfo type namepart |
|
switch -- $type { |
|
T { |
|
if {$name eq ""} { |
|
append name $namepart |
|
} else { |
|
append name .$namepart |
|
} |
|
} |
|
I { |
|
if {$name eq ""} { |
|
append name $namepart |
|
} else { |
|
append name .$namepart |
|
} |
|
} |
|
default { |
|
#end at first break in the leading sequence of T & I tablenames |
|
break |
|
} |
|
} |
|
} |
|
return $name |
|
} |
|
|
|
} |
|
|
|
tcl::namespace::eval tomlish::app { |
|
variable applist [list encoder decoder test] |
|
|
|
#*** !doctools |
|
#[subsection {Namespace tomlish::app}] |
|
#[para] |
|
#[list_begin definitions] |
|
|
|
proc decoder {args} { |
|
#*** !doctools |
|
#[call app::[fun decoder] [arg args]] |
|
#[para] read toml on stdin until EOF |
|
#[para] on error - returns non-zero exit code and writes error on stderr |
|
#[para] on success - returns zero exit code and writes JSON encoding of the data on stdout |
|
#[para] This decoder is intended to be compatible with toml-test |
|
|
|
set opts [dict merge [dict create] $args] |
|
#fconfigure stdin -encoding utf-8 |
|
fconfigure stdin -translation binary |
|
#Just slurp it all - presumably we are not handling massive amounts of data on stdin. |
|
# - even if the input is large, we probably don't gain much (aside from possible memory savings?) by attempting to process input as it arrives. |
|
if {[catch { |
|
set toml [read stdin] |
|
}]} { |
|
exit 2 ;#read error |
|
} |
|
try { |
|
set j [::tomlish::toml_to_json $toml] |
|
} on error {em} { |
|
puts stderr "decoding failed: '$em'" |
|
exit 1 |
|
} |
|
puts -nonewline stdout $j |
|
exit 0 |
|
} |
|
|
|
proc encoder {args} { |
|
#*** !doctools |
|
#[call app::[fun encoder] [arg args]] |
|
#[para] read JSON on stdin until EOF |
|
#[para] return non-zero exitcode if JSON data cannot be converted to a valid TOML representation |
|
#[para] return zero exitcode and TOML data on stdout if JSON data can be converted. |
|
#[para] This encoder is intended to be compatible with toml-test |
|
|
|
set opts [dict merge [dict create] $args] |
|
fconfigure stdin -translation binary |
|
if {[catch { |
|
set json [read stdin] |
|
}]} { |
|
exit 2 ;#read error |
|
} |
|
try { |
|
set toml [::tomlish::json_to_toml $json] |
|
} on error {em} { |
|
puts stderr "encoding failed: '$em'" |
|
exit 1 |
|
} |
|
puts -nonewline stdout $toml |
|
exit 0 |
|
} |
|
|
|
proc test {args} { |
|
set opts [dict merge [dict create] $args] |
|
|
|
package require test::tomlish |
|
if {[dict exists $opts -suite]} { |
|
test::tomlish::suite [dict get $opts -suite] |
|
} |
|
test::tomlish::run |
|
} |
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace tomlish::app ---}] |
|
} |
|
|
|
proc ::tomlish::appnames {} { |
|
set applist [list] |
|
foreach cmd [info commands ::tomlish::app::*] { |
|
lappend applist [namespace tail $cmd] |
|
} |
|
return $applist |
|
} |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Secondary API namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval tomlish::lib { |
|
namespace export {[a-z]*}; # Convention: export all lowercase |
|
namespace path [namespace parent] |
|
#*** !doctools |
|
#[subsection {Namespace tomlish::lib}] |
|
#[para] Secondary functions that are part of the API |
|
#[list_begin definitions] |
|
|
|
#proc utility1 {p1 args} { |
|
# #*** !doctools |
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
|
# #[para]Description of utility1 |
|
# return 1 |
|
#} |
|
|
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace tomlish::lib ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
if {$argc > 0} { |
|
puts stderr "argc: $argc args: $argv" |
|
|
|
if {($argc == 1)} { |
|
if {[tcl::string::tolower $argv] in {help -help h -h}} { |
|
puts stdout "Usage: -app <appname> where appname one of:[tomlish::appnames]" |
|
exit 0 |
|
} else { |
|
puts stderr "Argument '$argv' not understood. Try -help" |
|
exit 1 |
|
} |
|
} |
|
set opts [dict create] |
|
set opts [dict merge $opts $argv] |
|
|
|
set opts_understood [list -app ] |
|
if {"-app" in [dict keys $opts]} { |
|
#Don't vet the remaining opts - as they are interpreted by each app |
|
} else { |
|
foreach key [dict keys $opts] { |
|
if {$key ni $opts_understood} { |
|
puts stderr "Option '$key' not understood" |
|
exit 1 |
|
} |
|
} |
|
} |
|
if {[dict exists $opts -app]} { |
|
set app [dict get $opts -app] |
|
if {$app ni [tomlish::appnames]} { |
|
puts stderr "app '[dict get $opts -app]' not found" |
|
exit 1 |
|
} |
|
tomlish::app::$app {*}$opts |
|
} |
|
} |
|
|
|
## Ready |
|
package provide tomlish [namespace eval tomlish { |
|
variable pkg tomlish |
|
variable version |
|
set version 1.1.2 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end] |
|
|
|
|