AMG: [jsonEncode] converts from a tagged data format to JSON.
The available type tags are:
Array and object type composition is supported in two ways. If the type is array or object, each element is represented as a two-element list, being the type and the value. This gets quite cumbersome when the values all have uniform type, so the outer type may be a two-element list, the second of which is the type used for all values. More deeply nested data structures can be defined either by further nesting the second type element or by flattening the list.
% jsonEncode {string hello}
"hello"
% jsonEncode {number 42}
42
% jsonEncode {literal null}
null
% jsonEncode {array {{string hello} {number 42} {literal null}}}
["hello",42,null]
% jsonEncode {object {foo {string hello} bar {number 42} quux {literal null}}}
{"foo":"hello","bar":42,"quux":null}
% jsonEncode {array {{array {{number 1} {number 2}}} {array {{number 3} {number 4}}}}}
[[1,2],[3,4]]
% jsonEncode {{array {array number}} {{1 2} {3 4}}}
[[1,2],[3,4]]
% jsonEncode {{array array number} {{1 2} {3 4}}}
[[1,2],[3,4]]
% jsonEncode {{array array string} {{1 2} {3 4}}}
[["1","2"],["3","4"]]
% jsonEncode {{object object string} {name {first Andy last Goth} address {web http://tcl.tk/}}}
{"name":{"first":"Andy","last":"Goth"},"address":{"web":"http://tcl.tk/"}# jsonEncode --
# Encodes data in the JSON format per https://tools.ietf.org/html/rfc7159.
# Source: http://wiki.tcl.tk/49031
proc jsonEncode {data} {
# Extract type and value from data argument.
if {[llength $data] != 2} {
error "invalid JSON data: must be a two-element list consisting of\
type and value"
}
lassign $data type value
# Extract top and subtype from type element.
set toptype [lindex $type 0]
if {[llength $type] >= 2} {
if {[llength $type] == 2} {
set subtype [lindex $type 1]
} else {
set subtype [lrange $type 1 end]
}
if {$toptype ni {array object}} {
set toptype {}
}
}
# Perform type-specific JSON encoding.
switch $toptype {
array {
# Recursively encode each array element. If a subtype was specified, it
# is shared between all elements. Otherwise, each element is itself a
# two-element list consisting of type and value.
set first 1
append result \[
foreach element $value {
if {$first} {
set first 0
} else {
append result ,
}
if {[info exists subtype]} {
append result [jsonEncode [list $subtype $element]]
} else {
append result [jsonEncode $element]
}
}
append result \]
return $result
} object {
# Recursively encode each object key and element. Keys are always
# strings. If a subtype was specified, it is shared between all
# elements. Otherwise, each element is itself a two-element list
# consisting of type and underlying data value.
set first 1
append result \{
foreach {key element} $value {
if {$first} {
set first 0
} else {
append result ,
}
append result [jsonEncode [list string $key]] :
if {[info exists subtype]} {
append result [jsonEncode [list $subtype $element]]
} else {
append result [jsonEncode $element]
}
}
append result \}
return $result
} string {
# Encode the minimal set of required escape sequences.
return \"[string map {
\x00 \\u0000 \x01 \\u0001 \x02 \\u0002 \x03 \\u0003
\x04 \\u0004 \x05 \\u0005 \x06 \\u0006 \x07 \\u0007
\x08 \\u0008 \x09 \\u0009 \x0a \\u000a \x0b \\u000b
\x0c \\u000c \x0d \\u000d \x0e \\u000e \x0f \\u000f
\x10 \\u0010 \x11 \\u0011 \x12 \\u0012 \x13 \\u0013
\x14 \\u0014 \x15 \\u0015 \x16 \\u0016 \x17 \\u0017
\x18 \\u0018 \x19 \\u0019 \x1a \\u001a \x1b \\u001b
\x1c \\u001c \x1d \\u001d \x1e \\u001e \x1f \\u001f
\\ \\\\ \" \\\"
} $value]\"
} number {
# Attempt to normalize the number to comply with the JSON standard.
regsub {^\+(?=[\d.])} $value {} result ;# Strip leading plus.
regsub {^(-?)0+(?=\d)} $result {\1} result ;# Strip leading 0's.
regsub {(^|-)\.(?=\d)} $result {\10.} result ;# Prefix leading dot.
regsub {(\d)\.(?=\D|$)} $result {\1.0} result ;# Suffix trailing dot.
if {![regexp {^-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][-+]?\d+)?$} $result]} {
error "invalid JSON number \"$value\":\
see https://tools.ietf.org/html/rfc7159#section-6"
}
return $result
} literal {
# The only valid literals are false, null, and true.
if {$value ni {false null true}} {
error "invalid JSON literal \"$value\":\
must be false, null, or true"
}
return $value
} raw {
# Raw data. The caller must only supply correctly formatted JSON.
return $value
} default {
# Invalid type.
error "invalid JSON type \"$type\": must be array, object, string,
number, literal, raw, or {array|object ?...? subtype}, where
subtype is recursively any valid JSON type"
}}
}package require tcltest
foreach {name description argument result} {
1.1 "empty string"
{string {}}
{""}
1.2 "nonempty string"
{string hello}
{"hello"}
1.3 "string with quoted characters"
{string \"a\nb\\c\"}
{"\"a\u000ab\\c\""}
2.1 integer
{number 42}
42
2.2 "negative integer"
{number -42}
-42
2.3 "positive integer"
{number +42}
42
2.4 "leading zeroes"
{number 000}
0
2.5 zero
{number 0}
0
2.6 "negative zero"
{number -000}
-0
2.7 "real number"
{number 1.23}
1.23
2.8 "negative real number"
{number -1.23}
-1.23
2.9 "negative real number with exponent"
{number -1e5}
-1e5
2.10 "real number with capital exponent"
{number 1E5}
1E5
2.11 "real number with fraction and exponent"
{number 1.23e4}
1.23e4
2.12 "positive real number with fraction and positive exponent"
{number +1.23e+4}
1.23e+4
2.13 "real number with fraction and negative exponent"
{number 1.23e-4}
1.23e-4
2.14 "real number with dot and no fraction"
{number 1.}
1.0
2.15 "real number with dot and no integer"
{number .1}
0.1
2.16 "real number with dot, no fraction, and exponent"
{number 1.E5}
1.0E5
2.17 "real number with dot, no integer, and exponent"
{number .1E-5}
0.1E-5
2.18 "real number with leading zeroes"
{number 00123.45}
123.45
2.19 "small real number with leading zeroes"
{number 00000.45}
0.45
2.20 "zero real number with leading zeroes and exponent"
{number 00000e9}
0e9
3.1 "literal false"
{literal false}
false
3.2 "literal null"
{literal null}
null
3.3 "literal true"
{literal true}
true
4.1 "array with variable type"
{array {{string hello} {number 42} {literal null}}}
{["hello",42,null]}
4.2 "array with constant but unshared type"
{array {{array {{number 1} {number 2}}} {array {{number 3} {number 4}}}}}
{[[1,2],[3,4]]}
4.3 "array with shared type, nested syntax"
{{array {array number}} {{1 2} {3 4}}}
{[[1,2],[3,4]]}
4.4 "array with shared type, flattened syntax"
{{array array number} {{1 2} {3 4}}}
{[[1,2],[3,4]]}
4.5 "array of strings"
{{array array string} {{1 2} {3 4}}}
{[["1","2"],["3","4"]]}
4.6 "empty array"
{array {}}
{[]}
4.7 "empty array with unnecessary shared type"
{{array string} {}}
{[]}
5.1 "object with variable type"
{object {foo {string hello} bar {number 42} quux {literal null}}}
{{"foo":"hello","bar":42,"quux":null}}
5.2 "object with shared type, flattened syntax"
{{object object string} {name {first Andy last Goth} address {web http://tcl.tk/}}}
{{"name":{"first":"Andy","last":"Goth"},"address":{"web":"http://tcl.tk/"}}}
5.3 "empty object"
{object {}}
{{}}
5.4 "empty object with unnecessary shared type"
{{object string} {}}
{{}}
6.1 "empty raw"
{raw {}}
{}
6.2 "nonempty raw"
{raw {"foobar"}}
{"foobar"}
} {
tcltest::test jsonEncode-$name $description\
-body [list jsonEncode $argument] -result $result
}
tcltest::cleanupTests